From 9e78cce4000dde4666cb04fa1fb59a38cc3d8a2a Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 4 Aug 2020 17:47:54 +0530 Subject: [PATCH 01/63] Squashed commit of the following: commit 6aa60a4d72e2309c28e897d3bbe037a4b1fc5022 Author: Zubin Duggal Date: Fri Jun 5 15:46:30 2020 +0530 Separate out static LanguageContextData from dynamic, introduce LspM, handle initialize specially commit 0cf607f215979d25f637c08b8d56b16011741416 Author: Zubin Duggal Date: Fri Jun 5 00:48:06 2020 +0530 Eliminate duplication of parsing logic commit cb8bd3546e71e71b179f59059b0e93669d0b3929 Author: Zubin Duggal Date: Thu Jun 4 23:01:05 2020 +0530 Import LSP types unqualified in Core and other cleanup commit bb7a3f8cd94065fcf4d39012b39ab6e2b855291a Author: Zubin Duggal Date: Thu Jun 4 19:16:09 2020 +0530 tweaks for lsp-test commit 58609e1e2ead29165b84fad74b03f0db3d29060c Author: Luke Lau Date: Thu May 14 18:21:46 2020 +0100 Fix method type in Unregistration This could probably be backported commit 3f35d04dee069704551c53d13bb9357dacfbe1b3 Author: Luke Lau Date: Tue May 12 18:03:58 2020 +0100 Add back erroneous deletion commit 63b80f6981251c796db56087ee551037c2b98985 Author: Luke Lau Date: Tue May 12 17:58:48 2020 +0100 Update the example server commit 5514e76fd8c7223eea812fba3eafe279f14cd6e5 Author: Luke Lau Date: Tue May 12 17:27:11 2020 +0100 Tidy up some stuff in Core, add getVersionedTextDoc When wanting to create textdocumentedits, you need to pass a versioned text doc identifier. But often times the request that you are working with only gives you an unversioned text doc identifier. This is a helper function to convert it to the appropriate version by looking it up in the VFS. commit aedaa2a1ff0d8171f8085ec2c84e1bebba3dbdf9 Merge: 56a2c9e bce18bc Author: Luke Lau Date: Tue May 12 17:34:29 2020 +0100 Merge branch 'singleton-methods' of github.com:wz1000/haskell-lsp into singleton-methods commit bce18bcd344988e7e75990ff75ad1cb03be65f70 Author: Luke Lau Date: Tue May 12 16:37:21 2020 +0100 Hide LSP ids from the users This changes the send function into two separate functions, where parameters are passed instead of raw messages. That way haskell-lsp can do the bookkeeping work of figuring out the appropriate request id, and we can get rid of MessageFuncs since the user no longer needs to construct messages from scratch. commit 2d651148fc691d9c1f819131a188e67792acacba Author: Luke Lau Date: Mon May 11 16:40:55 2020 +0100 Rename old sendFunc -> sendMsg commit f08b599d8fbc1d21492245205c42690ad10dab6b Author: Luke Lau Date: Sun May 10 20:43:25 2020 +0100 Fix haddock Was interpreting the pipe as a haddock commit 56a2c9ef477a1ea720cd4972037fc31e5b195381 Author: Luke Lau Date: Mon May 11 16:40:55 2020 +0100 Rename old sendFunc -> sendMsg commit be92b485811f3758422ac52ac5f912e5b635b53e Author: Luke Lau Date: Sun May 10 20:43:25 2020 +0100 Fix haddock Was interpreting the pipe as a haddock commit cafca9823faa2db5f960f5ce981497fb6395c3ef Author: Luke Lau Date: Sun May 10 17:44:45 2020 +0100 Make *ResponseHandler newtypes commit a4fbbcf8cd3831d9ac089b169569cd5343637f11 Author: Luke Lau Date: Sun May 10 17:16:01 2020 +0100 Add explicit type parameter to LookupFunc Needed to build on ghc-8.10 Also some whitespace fixes my editor seemed to throw in automatically commit 2c32c5611ac87b7898c30847eb0c68e3a177148a Author: Zubin Duggal Date: Fri May 8 19:13:10 2020 +0530 Add utility functions for parsing server and client messages commit 2d67cb5f3992a4272d6a92bb6acd49962ef0f4e3 Author: Zubin Duggal Date: Fri May 8 15:46:06 2020 +0530 Rename Message -> Method, Types -> Message, extract LspId into its own module commit c51dc57ea5638b09ae4336e1f087b38029306e7e Author: Zubin Duggal Date: Fri May 8 15:03:03 2020 +0530 Make ResponseMessage use Either again commit 4b9341fcc60a9de60e0462482c77f487a368b82a Author: Zubin Duggal Date: Fri May 8 14:11:56 2020 +0530 Safer API for IxMap commit f2c617c1eb5c1bd83e12b2b4baee0f81dacb839d Author: Zubin Duggal Date: Fri May 8 13:07:43 2020 +0530 Split out IxMap into new module commit ddd85551758d1e657ebf1c3f9af1c599b46f155c Author: Zubin Duggal Date: Fri May 8 12:04:35 2020 +0530 move synonyms to new module commit a7ffa3e174b4e7de6466f6505d026d2645d5a331 Author: Zubin Duggal Date: Fri May 8 11:34:42 2020 +0530 remove capturing and misc spring cleaning commit 8e91bdb8fb246c3de4dd1339a76dd5cdaddbb79c Author: Zubin Duggal Date: Fri May 8 11:07:14 2020 +0530 vastly improve the TH for generating FromJSON method instances commit f6403bfecbefc3d3744f6af2d31e8a202cc9a364 Author: Zubin Duggal Date: Fri May 8 02:55:51 2020 +0530 Hack together some nasty looking TH to reduce SMethod FromJSON boilerplate commit b9ac06752e17e65809d088f6ed120fbc87a9672e Author: Zubin Duggal Date: Fri May 8 01:36:21 2020 +0530 Cleanup Core.hs commit 0c155536677914c5d90e491ea6e2461c52b2463e Author: Zubin Duggal Date: Thu May 7 20:33:04 2020 +0530 fix clientMethodJSON/serverMethodJSON commit 3f28fb238fb12e49ef2a28e78fe728bcd56b1811 Merge: c84e4e0 2ff1129 Author: Zubin Duggal Date: Thu May 7 18:14:23 2020 +0530 Merge branch 'master' of https://github.com/alanz/haskell-lsp into singleton-methods commit c84e4e0ce6cfacaa28e3ea836ebfb8c9539152e1 Merge: c194d51 c19ed85 Author: Zubin Duggal Date: Wed Apr 29 00:00:07 2020 +0530 Merge branch 'master' of https://github.com/alanz/haskell-lsp into singleton-methods commit c194d513cc8cc58ad485698727965c580fe2d536 Author: Zubin Duggal Date: Sat Apr 25 00:05:23 2020 +0530 Redesign methods once more commit bfb3b55526270005fa9c7a072c511dff83cf6059 Author: Zubin Duggal Date: Fri Dec 20 16:23:08 2019 +0530 Fix merge commit a098073e685461d1f68497016ae2b021f868359b Merge: 4cc2902 5497e9f Author: Zubin Duggal Date: Tue Dec 17 17:14:40 2019 +0530 Merge branch 'master' of https://github.com/alanz/haskell-lsp into singleton-methods commit 4cc2902d92b01e102b1a7b41c5ce28d1c31ceb76 Author: Zubin Duggal Date: Sat Jul 13 17:01:37 2019 +0530 Dependent types, type safe responses and methods --- .gitignore | 1 + example/Main.hs | 443 +++---- haskell-lsp-types/haskell-lsp-types.cabal | 8 +- haskell-lsp-types/src/Data/IxMap.hs | 40 + .../src/Language/Haskell/LSP/Types.hs | 6 + .../Language/Haskell/LSP/Types/CodeAction.hs | 4 - .../src/Language/Haskell/LSP/Types/Color.hs | 8 - .../Language/Haskell/LSP/Types/Completion.hs | 7 - .../Haskell/LSP/Types/DataTypesJSON.hs | 189 +-- .../Haskell/LSP/Types/FoldingRange.hs | 5 - .../src/Language/Haskell/LSP/Types/Hover.hs | 5 - .../src/Language/Haskell/LSP/Types/Lens.hs | 5 +- .../Language/Haskell/LSP/Types/Location.hs | 7 + .../src/Language/Haskell/LSP/Types/LspId.hs | 37 + .../src/Language/Haskell/LSP/Types/Message.hs | 901 +++++++------ .../Haskell/LSP/Types/MessageFuncs.hs | 341 ----- .../src/Language/Haskell/LSP/Types/Method.hs | 368 ++++++ .../src/Language/Haskell/LSP/Types/Symbol.hs | 3 - .../Language/Haskell/LSP/Types/Synonyms.hs | 174 +++ .../src/Language/Haskell/LSP/Types/Uri.hs | 4 +- .../src/Language/Haskell/LSP/Types/Utils.hs | 39 +- .../src/Language/Haskell/LSP/Types/Window.hs | 40 +- .../Haskell/LSP/Types/WorkspaceFolders.hs | 7 - haskell-lsp.cabal | 9 +- hie.yaml | 10 + src/Language/Haskell/LSP/Capture.hs | 55 - src/Language/Haskell/LSP/Control.hs | 113 +- src/Language/Haskell/LSP/Core.hs | 1159 +++++++---------- src/Language/Haskell/LSP/Messages.hs | 126 -- src/Language/Haskell/LSP/VFS.hs | 2 +- 30 files changed, 2050 insertions(+), 2066 deletions(-) create mode 100644 haskell-lsp-types/src/Data/IxMap.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs delete mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs create mode 100644 hie.yaml delete mode 100644 src/Language/Haskell/LSP/Capture.hs delete mode 100644 src/Language/Haskell/LSP/Messages.hs diff --git a/.gitignore b/.gitignore index 01e89fb2c..6b12656c7 100644 --- a/.gitignore +++ b/.gitignore @@ -14,6 +14,7 @@ stack*.yaml.lock /haskell-lsp-types/cabal.project.local~ *.swp *.swo +*.orig *.DS_Store .hspec-failures /haskell-lsp-types/dist/ diff --git a/example/Main.hs b/example/Main.hs index c028bd204..66ed6c231 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -4,7 +4,23 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} + +{- | +This is an example language server built with haskell-lsp using a 'Reactor' +design. With a 'Reactor' all requests are handled on a /single thread/. +A thread is spun up for it, which repeatedly reads from a 'TChan' of +'ReactorInput's. +The `haskell-lsp` handlers then simply pass on all the requests and +notifications onto the channel via 'ReactorInput's. + +To try out this server, install it with +> cabal install lsp-hello -fdemo +and plug it into your client of choice. +-} module Main (main) where import Control.Concurrent @@ -25,7 +41,6 @@ import qualified Data.Text as T import qualified Language.Haskell.LSP.Control as CTRL import qualified Language.Haskell.LSP.Core as Core import Language.Haskell.LSP.Diagnostics -import Language.Haskell.LSP.Messages import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J import qualified Language.Haskell.LSP.Utility as U @@ -70,8 +85,8 @@ run dispatcherProc = flip E.catches handlers $ do } flip E.finally finalProc $ do - Core.setupLogger (Just "/tmp/lsp-hello.log") [] L.DEBUG - CTRL.run callbacks (lspHandlers rin) lspOptions (Just "/tmp/lsp-hello-session.log") + Core.setupLogger Nothing [] L.DEBUG + CTRL.run callbacks (lspHandlers rin) lspOptions where handlers = [ E.Handler ioExcept @@ -83,13 +98,30 @@ run dispatcherProc = flip E.catches handlers $ do -- --------------------------------------------------------------------- +syncOptions :: J.TextDocumentSyncOptions +syncOptions = J.TextDocumentSyncOptions + { J._openClose = Just True + , J._change = Just J.TdSyncIncremental + , J._willSave = Just False + , J._willSaveWaitUntil = Just False + , J._save = Just $ J.SaveOptions $ Just False + } + +lspOptions :: Core.Options +lspOptions = def { Core.textDocumentSync = Just syncOptions + , Core.executeCommandCommands = Just ["lsp-hello-command"] + } + +-- --------------------------------------------------------------------- + -- The reactor is a process that serialises and buffers all requests from the -- LSP client, so they can be sent to the backend compiler one at a time, and a -- reply sent. -data ReactorInput - = HandlerRequest FromClientMessage - -- ^ injected into the reactor input by each of the individual callback handlers +data ReactorInput = forall t (m :: J.Method 'J.FromClient t). + ReactorInput (J.SMethod m) + (J.ClientMessage m) + (J.ResponseHandlerFunc m) -- --------------------------------------------------------------------- @@ -102,10 +134,20 @@ type R c a = ReaderT (Core.LspFuncs c) IO a -- --------------------------------------------------------------------- -reactorSend :: FromServerMessage -> R () () -reactorSend msg = do +reactorSendNot :: J.SServerMethod (m :: J.Method 'J.FromServer 'J.Notification) + -> J.MessageParams m + -> R () () +reactorSendNot method params = do + lf <- ask + liftIO $ Core.sendNot lf method params + +reactorSendReq :: J.SServerMethod (m :: J.Method 'J.FromServer 'J.Request) + -> J.MessageParams m + -> (J.LspId m -> Either J.ResponseError (J.ResponseParams m) -> R () ()) + -> R () (J.LspId m) +reactorSendReq method params responseHandler = do lf <- ask - liftIO $ Core.sendFunc lf msg + liftIO $ Core.sendReq lf method params (\lid res -> runReaderT (responseHandler lid res) lf) -- --------------------------------------------------------------------- @@ -116,202 +158,6 @@ publishDiagnostics maxToPublish uri v diags = do -- --------------------------------------------------------------------- -nextLspReqId :: R () J.LspId -nextLspReqId = do - f <- asks Core.getNextReqId - liftIO f - --- --------------------------------------------------------------------- - --- | The single point that all events flow through, allowing management of state --- to stitch replies and requests together from the two asynchronous sides: lsp --- server and backend compiler -reactor :: Core.LspFuncs () -> TChan ReactorInput -> IO () -reactor lf inp = do - liftIO $ U.logs "reactor:entered" - flip runReaderT lf $ forever $ do - inval <- liftIO $ atomically $ readTChan inp - case inval of - - -- Handle any response from a message originating at the server, such as - -- "workspace/applyEdit" - HandlerRequest (RspFromClient rm) -> do - liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm - - -- ------------------------------- - - HandlerRequest (NotInitialized _notification) -> do - liftIO $ U.logm "****** reactor: processing Initialized Notification" - -- Server is ready, register any specific capabilities we need - - {- - Example: - { - "method": "client/registerCapability", - "params": { - "registrations": [ - { - "id": "79eee87c-c409-4664-8102-e03263673f6f", - "method": "textDocument/willSaveWaitUntil", - "registerOptions": { - "documentSelector": [ - { "language": "javascript" } - ] - } - } - ] - } - } - -} - let - registration = J.Registration "lsp-hello-registered" J.WorkspaceExecuteCommand Nothing - let registrations = J.RegistrationParams (J.List [registration]) - rid <- nextLspReqId - - reactorSend $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest rid registrations - - -- example of showMessageRequest - let - params = J.ShowMessageRequestParams J.MtWarning "choose an option for XXX" - (Just [J.MessageActionItem "option a", J.MessageActionItem "option b"]) - rid1 <- nextLspReqId - - reactorSend $ ReqShowMessage $ fmServerShowMessageRequest rid1 params - - -- ------------------------------- - - HandlerRequest (NotDidOpenTextDocument notification) -> do - liftIO $ U.logm "****** reactor: processing NotDidOpenTextDocument" - let - doc = notification ^. J.params - . J.textDocument - . J.uri - fileName = J.uriToFilePath doc - liftIO $ U.logs $ "********* fileName=" ++ show fileName - sendDiagnostics (J.toNormalizedUri doc) (Just 0) - - -- ------------------------------- - - HandlerRequest (NotDidChangeTextDocument notification) -> do - let doc :: J.NormalizedUri - doc = notification ^. J.params - . J.textDocument - . J.uri - . to J.toNormalizedUri - mdoc <- liftIO $ Core.getVirtualFileFunc lf doc - case mdoc of - Just (VirtualFile _version str _) -> do - liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf got:" ++ show str - Nothing -> do - liftIO $ U.logs "reactor:processing NotDidChangeTextDocument: vf returned Nothing" - - liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: uri=" ++ show doc - - -- ------------------------------- - - HandlerRequest (NotDidSaveTextDocument notification) -> do - liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument" - let - doc = notification ^. J.params - . J.textDocument - . J.uri - fileName = J.uriToFilePath doc - liftIO $ U.logs $ "********* fileName=" ++ show fileName - sendDiagnostics (J.toNormalizedUri doc) Nothing - - -- ------------------------------- - - HandlerRequest (ReqRename req) -> do - liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req - let - _params = req ^. J.params - _doc = _params ^. J.textDocument . J.uri - J.Position _l _c' = _params ^. J.position - _newName = _params ^. J.newName - - let we = J.WorkspaceEdit - Nothing -- "changes" field is deprecated - (Just (J.List [])) -- populate with actual changes from the rename - let rspMsg = Core.makeResponseMessage req we - reactorSend $ RspRename rspMsg - - -- ------------------------------- - - HandlerRequest (ReqHover req) -> do - liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req - let J.TextDocumentPositionParams _doc pos _workDoneToken = req ^. J.params - J.Position _l _c' = pos - - let - ht = Just $ J.Hover ms (Just range) - ms = J.HoverContents $ J.markedUpContent "lsp-hello" "TYPE INFO" - range = J.Range pos pos - reactorSend $ RspHover $ Core.makeResponseMessage req ht - - -- ------------------------------- - - HandlerRequest (ReqCodeAction req) -> do - liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req - let params = req ^. J.params - doc = params ^. J.textDocument - -- fileName = drop (length ("file://"::String)) doc - -- J.Range from to = J._range (params :: J.CodeActionParams) - (J.List diags) = params ^. J.context . J.diagnostics - - let - -- makeCommand only generates commands for diagnostics whose source is us - makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] - where - title = "Apply LSP hello command:" <> head (T.lines _m) - -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above - cmd = "lsp-hello-command" - -- need 'file' and 'start_pos' - args = J.List - [ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])] - , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])] - ] - cmdparams = Just args - makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] - let body = J.List $ map J.CACommand $ concatMap makeCommand diags - rsp = Core.makeResponseMessage req body - reactorSend $ RspCodeAction rsp - - -- ------------------------------- - - HandlerRequest (ReqExecuteCommand req) -> do - liftIO $ U.logs "reactor:got ExecuteCommandRequest:" -- ++ show req - let params = req ^. J.params - margs = params ^. J.arguments - - liftIO $ U.logs $ "reactor:ExecuteCommandRequest:margs=" ++ show margs - - let - reply v = reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req v - -- When we get a RefactorResult or HieDiff, we need to send a - -- separate WorkspaceEdit Notification - r = J.List [] :: J.List Int - liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show r - case toWorkspaceEdit r of - Just we -> do - reply (J.Object mempty) - lid <- nextLspReqId - -- reactorSend $ J.RequestMessage "2.0" lid "workspace/applyEdit" (Just we) - reactorSend $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest lid we - Nothing -> - reply (J.Object mempty) - - -- ------------------------------- - - HandlerRequest om -> do - liftIO $ U.logs $ "reactor:got HandlerRequest:" ++ show om - --- --------------------------------------------------------------------- - -toWorkspaceEdit :: t -> Maybe J.ApplyWorkspaceEditParams -toWorkspaceEdit _ = Nothing - --- --------------------------------------------------------------------- - -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification sendDiagnostics :: J.NormalizedUri -> Maybe Int -> R () () @@ -331,45 +177,154 @@ sendDiagnostics fileUri version = do -- --------------------------------------------------------------------- -syncOptions :: J.TextDocumentSyncOptions -syncOptions = J.TextDocumentSyncOptions - { J._openClose = Just True - , J._change = Just J.TdSyncIncremental - , J._willSave = Just False - , J._willSaveWaitUntil = Just False - , J._save = Just $ J.SaveOptions $ Just False - } - -lspOptions :: Core.Options -lspOptions = def { Core.textDocumentSync = Just syncOptions - , Core.executeCommandCommands = Just ["lsp-hello-command"] - } +-- | The single point that all events flow through, allowing management of state +-- to stitch replies and requests together from the two asynchronous sides: lsp +-- server and backend compiler +reactor :: Core.LspFuncs () -> TChan ReactorInput -> IO () +reactor lf inp = do + liftIO $ U.logs "reactor:entered" + flip runReaderT lf $ forever $ do + ReactorInput method msg responder <- (liftIO $ atomically $ readTChan inp) + case handle method of + Just f -> f msg responder + Nothing -> pure () +-- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as +-- input into the reactor lspHandlers :: TChan ReactorInput -> Core.Handlers -lspHandlers rin - = def { Core.initializedHandler = Just $ passHandler rin NotInitialized - , Core.renameHandler = Just $ passHandler rin ReqRename - , Core.hoverHandler = Just $ passHandler rin ReqHover - , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument - , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument - , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument - , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument - , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient - , Core.responseHandler = Just $ responseHandlerCb rin - , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction - , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand - } - --- --------------------------------------------------------------------- - -passHandler :: TChan ReactorInput -> (a -> FromClientMessage) -> Core.Handler a -passHandler rin c notification = do - atomically $ writeTChan rin (HandlerRequest (c notification)) - --- --------------------------------------------------------------------- - -responseHandlerCb :: TChan ReactorInput -> Core.Handler J.BareResponseMessage -responseHandlerCb _rin resp = do - U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp +lspHandlers rin method = + case handle method of + Just _ -> Just $ Core.Handler $ \clientMsg (Core.ClientResponseHandler responder) -> + atomically $ writeTChan rin (ReactorInput method clientMsg responder) + Nothing -> Nothing + +-- | Where the actual logic resides for handling requests and notifications. +handle :: J.SMethod m -> Maybe (J.ClientMessage m -> J.ResponseHandlerFunc m -> R () ()) +handle J.SInitialized = Just $ \_msg () -> do + liftIO $ U.logm "Processing the Initialized notification" + -- Server is ready, register any specific capabilities we need + + {- + Example: + { + "method": "client/registerCapability", + "params": { + "registrations": [ + { + "id": "79eee87c-c409-4664-8102-e03263673f6f", + "method": "textDocument/willSaveWaitUntil", + "registerOptions": { + "documentSelector": [ + { "language": "javascript" } + ] + } + } + ] + } + } + -} + let registration = J.Registration "lsp-hello-registered" + (J.SomeClientMethod J.SWorkspaceExecuteCommand) + Nothing + regParams = J.RegistrationParams (J.List [registration]) + void $ reactorSendReq J.SClientRegisterCapability regParams $ \_lid res -> + case res of + Left e -> liftIO $ U.logs $ "Got an error: " ++ show e + Right J.Empty -> liftIO $ U.logm "Got a response for registering WorkspaceExecuteCommand" + + -- example of showMessageRequest + let params = J.ShowMessageRequestParams + J.MtWarning + "What's your favourite language extension?" + (Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"]) + + void $ reactorSendReq J.SWindowShowMessageRequest params $ \_lid res -> + case res of + Left e -> liftIO $ U.logs $ "Got an error: " ++ show e + Right _ -> reactorSendNot J.SWindowShowMessage + (J.ShowMessageParams J.MtInfo "Excellent choice") + +handle J.STextDocumentDidOpen = Just $ \msg () -> do + let doc = msg ^. J.params . J.textDocument . J.uri + fileName = J.uriToFilePath doc + liftIO $ U.logs $ "Processing DidOpenTextDocument for: " ++ show fileName + sendDiagnostics (J.toNormalizedUri doc) (Just 0) + +handle J.STextDocumentDidChange = Just $ \msg () -> do + let doc = msg ^. J.params + . J.textDocument + . J.uri + . to J.toNormalizedUri + liftIO $ U.logs $ "Processing DidChangeTextDocument for: " ++ show doc + lf <- ask + mdoc <- liftIO $ Core.getVirtualFileFunc lf doc + case mdoc of + Just (VirtualFile _version str _) -> do + liftIO $ U.logs $ "Found the virtual file: " ++ show str + Nothing -> do + liftIO $ U.logs $ "Didn't find anything in the VFS for: " ++ show doc + +handle J.STextDocumentDidSave = Just $ \msg () -> do + let doc = msg ^. J.params . J.textDocument . J.uri + fileName = J.uriToFilePath doc + liftIO $ U.logs $ "Processing DidSaveTextDocument for: " ++ show fileName + sendDiagnostics (J.toNormalizedUri doc) Nothing + +handle J.STextDocumentRename = Just $ \req responder -> do + liftIO $ U.logs "Processing a textDocument/rename request" + let params = req ^. J.params + J.Position l c = params ^. J.position + newName = params ^. J.newName + lf <- ask + vdoc <- liftIO $ Core.getVersionedTextDocFunc lf (params ^. J.textDocument) + -- Replace some text at the position with what the user entered + let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName + tde = J.TextDocumentEdit vdoc (J.List [edit]) + -- "documentChanges" field is preferred over "changes" + rsp = J.WorkspaceEdit Nothing (Just (J.List [tde])) + liftIO $ responder (Right rsp) + +handle J.STextDocumentHover = Just $ \req responder -> do + liftIO $ U.logs "Processing a textDocument/hover request" + let J.TextDocumentPositionParams _doc pos _workDoneToken = req ^. J.params + J.Position _l _c' = pos + rsp = Just $ J.Hover ms (Just range) + ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" + range = J.Range pos pos + liftIO $ responder (Right rsp) + +handle J.STextDocumentCodeAction = Just $ \req responder -> do + liftIO $ U.logs $ "Processing a textDocument/codeAction request" + let params = req ^. J.params + doc = params ^. J.textDocument + (J.List diags) = params ^. J.context . J.diagnostics + -- makeCommand only generates commands for diagnostics whose source is us + makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] + where + title = "Apply LSP hello command:" <> head (T.lines _m) + -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above + cmd = "lsp-hello-command" + -- need 'file' and 'start_pos' + args = J.List + [ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])] + , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])] + ] + cmdparams = Just args + makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] + rsp = J.List $ map J.CACommand $ concatMap makeCommand diags + liftIO $ responder (Right rsp) + +handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do + liftIO $ U.logs "Processing a workspace/executeCommand request" + let params = req ^. J.params + margs = params ^. J.arguments + + liftIO $ U.logs $ "The arguments are: " ++ show margs + liftIO $ responder (Right (J.Object mempty)) -- respond to the request + + reactorSendNot J.SWindowShowMessage + (J.ShowMessageParams J.MtInfo "I was told to execute a command") + +handle _ = Nothing -- --------------------------------------------------------------------- diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index b73eab913..aa4c544ef 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -21,8 +21,8 @@ library , Language.Haskell.LSP.Types.Capabilities , Language.Haskell.LSP.Types.Constants , Language.Haskell.LSP.Types.Lens - , Language.Haskell.LSP.Types.MessageFuncs , Language.Haskell.LSP.Types.Utils + , Data.IxMap other-modules: Language.Haskell.LSP.Types.ClientCapabilities , Language.Haskell.LSP.Types.CodeAction , Language.Haskell.LSP.Types.Color @@ -35,10 +35,13 @@ library , Language.Haskell.LSP.Types.Hover , Language.Haskell.LSP.Types.List , Language.Haskell.LSP.Types.Location + , Language.Haskell.LSP.Types.LspId , Language.Haskell.LSP.Types.MarkupContent + , Language.Haskell.LSP.Types.Method , Language.Haskell.LSP.Types.Message , Language.Haskell.LSP.Types.Progress , Language.Haskell.LSP.Types.Symbol + , Language.Haskell.LSP.Types.Synonyms , Language.Haskell.LSP.Types.TextDocument , Language.Haskell.LSP.Types.Uri , Language.Haskell.LSP.Types.Window @@ -51,6 +54,7 @@ library , aeson >=1.2.2.0 , binary , bytestring + , containers , data-default , deepseq , filepath @@ -58,7 +62,9 @@ library , lens >= 4.15.2 , network-uri , scientific + , some , text + , template-haskell , unordered-containers hs-source-dirs: src default-language: Haskell2010 diff --git a/haskell-lsp-types/src/Data/IxMap.hs b/haskell-lsp-types/src/Data/IxMap.hs new file mode 100644 index 000000000..bcd5cb24b --- /dev/null +++ b/haskell-lsp-types/src/Data/IxMap.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.IxMap where + +import qualified Data.Map as M +import Data.Some +import Data.Kind +import Unsafe.Coerce + +-- a `compare` b <=> toBase a `compare` toBase b +-- toBase (i :: f a) == toBase (j :: f b) <=> a ~ b +class Ord (Base f) => IxOrd f where + type Base f + toBase :: forall a. f a -> Base f + +newtype IxMap (k :: a -> Type) (f :: a -> Type) = IxMap { getMap :: M.Map (Base k) (Some f) } + +emptyIxMap :: IxMap k f +emptyIxMap = IxMap M.empty + +insertIxMap :: IxOrd k => k m -> f m -> IxMap k f -> Maybe (IxMap k f) +insertIxMap (toBase -> i) x (IxMap m) + | M.notMember i m = Just $ IxMap $ M.insert i (mkSome x) m + | otherwise = Nothing + +lookupIxMap :: IxOrd k => k m -> IxMap k f -> Maybe (f m) +lookupIxMap i (IxMap m) = + case M.lookup (toBase i) m of + Just (Some v) -> Just $ unsafeCoerce v + Nothing -> Nothing + +pickFromIxMap :: IxOrd k => k m -> IxMap k f -> (Maybe (f m), IxMap k f) +pickFromIxMap i (IxMap m) = + case M.updateLookupWithKey (\_ _ -> Nothing) (toBase i) m of + (Nothing,m) -> (Nothing,IxMap m) + (Just (Some k),m) -> (Just (unsafeCoerce k),IxMap m) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 1108f03db..7e36ab736 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -10,10 +10,13 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Hover , module Language.Haskell.LSP.Types.List , module Language.Haskell.LSP.Types.Location + , module Language.Haskell.LSP.Types.LspId , module Language.Haskell.LSP.Types.MarkupContent + , module Language.Haskell.LSP.Types.Method , module Language.Haskell.LSP.Types.Message , module Language.Haskell.LSP.Types.Progress , module Language.Haskell.LSP.Types.Symbol + , module Language.Haskell.LSP.Types.Synonyms , module Language.Haskell.LSP.Types.TextDocument , module Language.Haskell.LSP.Types.Uri , module Language.Haskell.LSP.Types.Window @@ -33,10 +36,13 @@ import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.MarkupContent +import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.Synonyms import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Window diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs index d4017e8f4..9b6a736b0 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs @@ -12,7 +12,6 @@ import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location -import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.WorkspaceEdit @@ -289,6 +288,3 @@ instance FromJSON CAResult where instance ToJSON CAResult where toJSON (CACommand x) = toJSON x toJSON (CACodeAction x) = toJSON x - -type CodeActionRequest = RequestMessage ClientMethod CodeActionParams (List CAResult) -type CodeActionResponse = ResponseMessage (List CAResult) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs index 42d641677..f83cd2ef2 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs @@ -7,7 +7,6 @@ import Data.Text ( Text ) import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location -import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.WorkspaceEdit @@ -105,10 +104,6 @@ data DocumentColorParams = deriveJSON lspOptions ''DocumentColorParams -type DocumentColorRequest = - RequestMessage ClientMethod DocumentColorParams (List ColorInformation) -type DocumentColorResponse = ResponseMessage (List ColorInformation) - {- Color Presentation Request (:leftwards_arrow_with_hook:) Since version 3.6.0 @@ -198,6 +193,3 @@ data ColorPresentation = deriveJSON lspOptions ''ColorPresentation -type ColorPresentationRequest = - RequestMessage ClientMethod ColorPresentationParams (List ColorPresentation) -type ColorPresentationResponse = ResponseMessage (List ColorPresentation) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs index a7259a019..78cf244ec 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs @@ -14,7 +14,6 @@ import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.MarkupContent -import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils @@ -458,9 +457,6 @@ data CompletionParams = deriveJSON lspOptions ''CompletionParams -type CompletionResponse = ResponseMessage CompletionResponseResult -type CompletionRequest = RequestMessage ClientMethod CompletionParams CompletionResponseResult - -- ------------------------------------- {- New in 3.0 @@ -509,6 +505,3 @@ Response result: CompletionItem error: code and message set in case an exception happens during the completion resolve request. -} - -type CompletionItemResolveRequest = RequestMessage ClientMethod CompletionItem CompletionItem -type CompletionItemResolveResponse = ResponseMessage CompletionItem diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index a18bc82c7..2386293d8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -7,6 +7,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.LSP.Types.DataTypesJSON where @@ -27,9 +30,9 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location -import Language.Haskell.LSP.Types.Message +import Language.Haskell.LSP.Types.LspId +import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.Progress -import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.WorkspaceEdit @@ -796,10 +799,6 @@ deriveJSON lspOptions ''InitializeResponseCapabilities -- --------------------------------------------------------------------- -type InitializeResponse = ResponseMessage InitializeResponseCapabilities - -type InitializeRequest = RequestMessage ClientMethod InitializeParams InitializeResponseCapabilities - {- error.code: @@ -858,8 +857,6 @@ instance A.FromJSON InitializedParams where instance A.ToJSON InitializedParams where toJSON InitializedParams = A.Object mempty -type InitializedNotification = NotificationMessage ClientMethod (Maybe InitializedParams) - -- --------------------------------------------------------------------- {- Shutdown Request @@ -884,9 +881,6 @@ Response -} -type ShutdownRequest = RequestMessage ClientMethod (Maybe A.Value) (Maybe ()) -type ShutdownResponse = ResponseMessage (Maybe ()) - -- --------------------------------------------------------------------- {- Exit Notification @@ -911,8 +905,6 @@ data ExitParams = deriveJSON defaultOptions ''ExitParams -type ExitNotification = NotificationMessage ClientMethod (Maybe ExitParams) - -- --------------------------------------------------------------------- {- Telemetry Notification @@ -929,16 +921,6 @@ Notification: -} -type TelemetryNotification = NotificationMessage ServerMethod A.Value - -type CustomClientNotification = NotificationMessage ClientMethod A.Value -type CustomServerNotification = NotificationMessage ServerMethod A.Value - -type CustomClientRequest = RequestMessage ClientMethod A.Value A.Value -type CustomServerRequest = RequestMessage ServerMethod A.Value A.Value - -type CustomResponse = ResponseMessage A.Value - -- --------------------------------------------------------------------- {- New in 3.0 @@ -991,26 +973,21 @@ data Registration = _id :: Text -- | The method / capability to register for. - , _method :: ClientMethod + , _method :: SomeClientMethod -- | Options necessary for the registration. , _registerOptions :: Maybe A.Value - } deriving (Show, Read, Eq) + } deriving (Show, Eq) deriveJSON lspOptions ''Registration data RegistrationParams = RegistrationParams { _registrations :: List Registration - } deriving (Show, Read, Eq) + } deriving (Show, Eq) deriveJSON lspOptions ''RegistrationParams --- |Note: originates at the server -type RegisterCapabilityRequest = RequestMessage ServerMethod RegistrationParams () - -type RegisterCapabilityResponse = ResponseMessage () - -- ------------------------------------- {- @@ -1077,23 +1054,19 @@ data Unregistration = -- provided during the register request. _id :: Text - -- |The method / capability to unregister for. - , _method :: Text - } deriving (Show, Read, Eq) + -- | The method / capability to unregister for. + , _method :: SomeClientMethod + } deriving (Show, Eq) deriveJSON lspOptions ''Unregistration data UnregistrationParams = UnregistrationParams { _unregistrations :: List Unregistration - } deriving (Show, Read, Eq) + } deriving (Show, Eq) deriveJSON lspOptions ''UnregistrationParams -type UnregisterCapabilityRequest = RequestMessage ServerMethod UnregistrationParams () - -type UnregisterCapabilityResponse = ResponseMessage () - -- --------------------------------------------------------------------- -- /** @@ -1215,8 +1188,6 @@ deriveJSON lspOptions ''DidChangeConfigurationParams -- --------------------------------------------------------------------- -type DidChangeConfigurationNotification = NotificationMessage ClientMethod DidChangeConfigurationParams - {- Configuration Request (:arrow_right_hook:) Since version 3.6.0 @@ -1281,9 +1252,6 @@ data ConfigurationParams = deriveJSON lspOptions ''ConfigurationParams -type ConfigurationRequest = RequestMessage ServerMethod ConfigurationParams (List A.Value) -type ConfigurationResponse = ResponseMessage (List A.Value) - -- --------------------------------------------------------------------- {- DidOpenTextDocument Notification @@ -1317,8 +1285,6 @@ data DidOpenTextDocumentParams = deriveJSON lspOptions ''DidOpenTextDocumentParams -type DidOpenTextDocumentNotification = NotificationMessage ClientMethod DidOpenTextDocumentParams - -- --------------------------------------------------------------------- {- DidChangeTextDocument Notification @@ -1388,7 +1354,6 @@ data DidChangeTextDocumentParams = deriveJSON lspOptions ''DidChangeTextDocumentParams -type DidChangeTextDocumentNotification = NotificationMessage ClientMethod DidChangeTextDocumentParams {- New in 3.0 ---------- @@ -1497,8 +1462,6 @@ data WillSaveTextDocumentParams = deriveJSON lspOptions ''WillSaveTextDocumentParams -type WillSaveTextDocumentNotification = NotificationMessage ClientMethod WillSaveTextDocumentParams - -- --------------------------------------------------------------------- {- New in 3.0 @@ -1526,9 +1489,6 @@ Response: Registration Options: TextDocumentRegistrationOptions -} -type WillSaveWaitUntilTextDocumentRequest = RequestMessage ClientMethod WillSaveTextDocumentParams (List TextEdit) -type WillSaveWaitUntilTextDocumentResponse = ResponseMessage (List TextEdit) - -- --------------------------------------------------------------------- {- DidSaveTextDocument Notification @@ -1555,10 +1515,6 @@ data DidSaveTextDocumentParams = deriveJSON lspOptions ''DidSaveTextDocumentParams -type DidSaveTextDocumentNotification = NotificationMessage ClientMethod DidSaveTextDocumentParams - - - -- --------------------------------------------------------------------- {- DidCloseTextDocument Notification @@ -1592,9 +1548,6 @@ data DidCloseTextDocumentParams = deriveJSON lspOptions ''DidCloseTextDocumentParams - -type DidCloseTextDocumentNotification = NotificationMessage ClientMethod DidCloseTextDocumentParams - -- --------------------------------------------------------------------- {- DidChangeWatchedFiles Notification @@ -1683,9 +1636,6 @@ data DidChangeWatchedFilesParams = deriveJSON lspOptions ''DidChangeWatchedFilesParams - -type DidChangeWatchedFilesNotification = NotificationMessage ClientMethod DidChangeWatchedFilesParams - -- --------------------------------------------------------------------- {- PublishDiagnostics Notification @@ -1721,9 +1671,6 @@ data PublishDiagnosticsParams = deriveJSON lspOptions ''PublishDiagnosticsParams - -type PublishDiagnosticsNotification = NotificationMessage ServerMethod PublishDiagnosticsParams - -- --------------------------------------------------------------------- {- Signature Help Request @@ -1843,9 +1790,6 @@ data SignatureHelp = deriveJSON lspOptions ''SignatureHelp -type SignatureHelpRequest = RequestMessage ClientMethod TextDocumentPositionParams SignatureHelp -type SignatureHelpResponse = ResponseMessage SignatureHelp - -- ------------------------------------- {- New in 3.0 @@ -1908,9 +1852,6 @@ instance A.FromJSON LocationResponseParams where parseJSON xs@(A.Array _) = MultiLoc <$> parseJSON xs parseJSON x = SingleLoc <$> parseJSON x -type DefinitionRequest = RequestMessage ClientMethod TextDocumentPositionParams LocationResponseParams -type DefinitionResponse = ResponseMessage LocationResponseParams - -- --------------------------------------------------------------------- {- @@ -1930,9 +1871,6 @@ error: code and message set in case an exception happens during the definition r Registration Options: TextDocumentRegistrationOptions -} -type TypeDefinitionRequest = RequestMessage ClientMethod TextDocumentPositionParams LocationResponseParams -type TypeDefinitionResponse = ResponseMessage LocationResponseParams - -- --------------------------------------------------------------------- {- @@ -1952,10 +1890,6 @@ error: code and message set in case an exception happens during the definition r Registration Options: TextDocumentRegistrationOptions -} - -type ImplementationRequest = RequestMessage ClientMethod TextDocumentPositionParams LocationResponseParams -type ImplementationResponse = ResponseMessage LocationResponseParams - -- --------------------------------------------------------------------- {- @@ -2012,10 +1946,6 @@ data ReferenceParams = deriveJSON lspOptions ''ReferenceParams - -type ReferencesRequest = RequestMessage ClientMethod ReferenceParams (List Location) -type ReferencesResponse = ResponseMessage (List Location) - -- --------------------------------------------------------------------- {- Document Highlights Request @@ -2112,9 +2042,6 @@ data DocumentHighlight = deriveJSON lspOptions ''DocumentHighlight -type DocumentHighlightRequest = RequestMessage ClientMethod TextDocumentPositionParams (List DocumentHighlight) -type DocumentHighlightsResponse = ResponseMessage (List DocumentHighlight) - -- --------------------------------------------------------------------- {- Workspace Symbols Request @@ -2154,9 +2081,6 @@ data WorkspaceSymbolParams = deriveJSON lspOptions ''WorkspaceSymbolParams -type WorkspaceSymbolRequest = RequestMessage ClientMethod WorkspaceSymbolParams (List SymbolInformation) -type WorkspaceSymbolsResponse = ResponseMessage (List SymbolInformation) - -- --------------------------------------------------------------------- {- Code Lens Request @@ -2231,10 +2155,6 @@ data CodeLens = deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens - -type CodeLensRequest = RequestMessage ClientMethod CodeLensParams (List CodeLens) -type CodeLensResponse = ResponseMessage (List CodeLens) - -- ------------------------------------- {- Registration Options: CodeLensRegistrationOptions defined as follows: @@ -2278,9 +2198,6 @@ Response -} -type CodeLensResolveRequest = RequestMessage ClientMethod CodeLens CodeLens -type CodeLensResolveResponse = ResponseMessage CodeLens - -- --------------------------------------------------------------------- {- New in 3.0 @@ -2349,10 +2266,6 @@ data DocumentLink = } deriving (Show, Read, Eq) deriveJSON lspOptions ''DocumentLink - -type DocumentLinkRequest = RequestMessage ClientMethod DocumentLinkParams (List DocumentLink) -type DocumentLinkResponse = ResponseMessage (List DocumentLink) - -- --------------------------------------------------------------------- {- New in 3.0 @@ -2373,10 +2286,6 @@ Response: error: code and message set in case an exception happens during the document link resolve request. -} - -type DocumentLinkResolveRequest = RequestMessage ClientMethod DocumentLink DocumentLink -type DocumentLinkResolveResponse = ResponseMessage DocumentLink - -- --------------------------------------------------------------------- {- Document Formatting Request @@ -2450,10 +2359,6 @@ data DocumentFormattingParams = } deriving (Show,Read,Eq) deriveJSON lspOptions ''DocumentFormattingParams - -type DocumentFormattingRequest = RequestMessage ClientMethod DocumentFormattingParams (List TextEdit) -type DocumentFormattingResponse = ResponseMessage (List TextEdit) - -- --------------------------------------------------------------------- {- Document Range Formatting Request @@ -2503,9 +2408,6 @@ data DocumentRangeFormattingParams = deriveJSON lspOptions ''DocumentRangeFormattingParams -type DocumentRangeFormattingRequest = RequestMessage ClientMethod DocumentRangeFormattingParams (List TextEdit) -type DocumentRangeFormattingResponse = ResponseMessage (List TextEdit) - -- --------------------------------------------------------------------- {- Document on Type Formatting Request @@ -2572,9 +2474,6 @@ data DocumentOnTypeFormattingParams = deriveJSON lspOptions ''DocumentOnTypeFormattingParams -type DocumentOnTypeFormattingRequest = RequestMessage ClientMethod DocumentOnTypeFormattingParams (List TextEdit) -type DocumentOnTypeFormattingResponse = ResponseMessage (List TextEdit) - data DocumentOnTypeFormattingRegistrationOptions = DocumentOnTypeFormattingRegistrationOptions { _firstTriggerCharacter :: Text @@ -2638,9 +2537,6 @@ deriveJSON lspOptions ''RenameParams -- {\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"textDocument/rename\",\"params\":{\"textDocument\":{\"uri\":\"file:///home/alanz/mysrc/github/alanz/haskell-lsp/src/HieVscode.hs\"},\"position\":{\"line\":37,\"character\":17},\"newName\":\"getArgs'\"}} -type RenameRequest = RequestMessage ClientMethod RenameParams WorkspaceEdit -type RenameResponse = ResponseMessage WorkspaceEdit - -- --------------------------------------------------------------------- {- Prepare Rename Request @@ -2674,18 +2570,16 @@ data RangeWithPlaceholder = { _range :: Range , _placeholder :: Text - } + } deriving Eq deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''RangeWithPlaceholder data RangeOrRangeWithPlaceholder = RangeWithPlaceholderValue RangeWithPlaceholder | RangeValue Range + deriving Eq deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''RangeOrRangeWithPlaceholder -type PrepareRenameRequest = RequestMessage ClientMethod TextDocumentPositionParams Range -type PrepareRenameResponse = ResponseMessage (Maybe RangeOrRangeWithPlaceholder) - -- --------------------------------------------------------------------- {- New in 3.0 @@ -2746,9 +2640,6 @@ data ExecuteCommandParams = deriveJSON lspOptions ''ExecuteCommandParams -type ExecuteCommandRequest = RequestMessage ClientMethod ExecuteCommandParams A.Value -type ExecuteCommandResponse = ResponseMessage A.Value - data ExecuteCommandRegistrationOptions = ExecuteCommandRegistrationOptions { _commands :: List Text @@ -2806,12 +2697,6 @@ data ApplyWorkspaceEditResponseBody = deriveJSON lspOptions ''ApplyWorkspaceEditResponseBody --- | Sent from the server to the client -type ApplyWorkspaceEditRequest = RequestMessage ServerMethod ApplyWorkspaceEditParams ApplyWorkspaceEditResponseBody -type ApplyWorkspaceEditResponse = ResponseMessage ApplyWorkspaceEditResponseBody - --- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -- --------------------------------------------------------------------- data TraceParams = @@ -2828,3 +2713,49 @@ data TraceNotification = } deriving (Show, Read, Eq) deriveJSON lspOptions ''TraceNotification + +-- --------------------------------------------------------------------- +{- +Cancellation Support + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#cancellation-support + + New: The base protocol now offers support for request cancellation. To + cancel a request, a notification message with the following properties is + sent: + +Notification: + + method: '$/cancelRequest' + params: CancelParams defined as follows: + +interface CancelParams { + /** + * The request id to cancel. + */ + id: number | string; +} + +A request that got canceled still needs to return from the server and send a +response back. It can not be left open / hanging. This is in line with the JSON +RPC protocol that requires that every request sends a response back. In addition +it allows for returning partial results on cancel. +-} + +data CancelParams = forall m. + CancelParams + { _id :: LspId m + } + +deriving instance Read CancelParams +deriving instance Show CancelParams +instance Eq CancelParams where + (CancelParams a) == CancelParams b = + case (a,b) of + (IdInt x, IdInt y) -> x == y + (IdString x, IdString y) -> x == y + _ -> False + +deriveJSON lspOptions ''CancelParams + +-- --------------------------------------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs index 6ca93076c..d25529514 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs @@ -6,10 +6,8 @@ import qualified Data.Aeson as A import Data.Aeson.TH import Data.Text (Text) import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument -import Language.Haskell.LSP.Types.Message data FoldingRangeParams = FoldingRangeParams @@ -67,6 +65,3 @@ data FoldingRange = deriving (Read, Show, Eq) deriveJSON lspOptions ''FoldingRange - -type FoldingRangeRequest = RequestMessage ClientMethod FoldingRangeParams (List FoldingRange) -type FoldingRangeResponse = ResponseMessage (List FoldingRange) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs index c46a85251..52d2cb534 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs @@ -11,8 +11,6 @@ import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.MarkupContent -import Language.Haskell.LSP.Types.Message -import Language.Haskell.LSP.Types.TextDocument -- --------------------------------------------------------------------- @@ -146,6 +144,3 @@ data Hover = } deriving (Read,Show,Eq) deriveJSON lspOptions ''Hover - -type HoverRequest = RequestMessage ClientMethod TextDocumentPositionParams (Maybe Hover) -type HoverResponse = ResponseMessage (Maybe Hover) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index c91b1c577..e42f05ca4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -2,6 +2,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} module Language.Haskell.LSP.Types.Lens where @@ -15,13 +18,13 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Hover -import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders +import Language.Haskell.LSP.Types.Message import Control.Lens.TH -- client capabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs index 97487ed97..7f38e8ffb 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs @@ -97,3 +97,10 @@ data Location = instance NFData Location deriveJSON lspOptions ''Location + +-- --------------------------------------------------------------------- + +-- | A helper function for creating ranges. +-- prop> mkRange l c l' c' = Range (Position l c) (Position l' c') +mkRange :: Int -> Int -> Int -> Int -> Range +mkRange l c l' c' = Range (Position l c) (Position l' c') \ No newline at end of file diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs new file mode 100644 index 000000000..884858168 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +module Language.Haskell.LSP.Types.LspId where + +import qualified Data.Aeson as A +import Data.Text (Text) +import Data.IxMap +import Language.Haskell.LSP.Types.Method + +-- | Id used for a request, Can be either a String or an Int +data LspId (m :: Method p Request) = IdInt Int | IdString Text + deriving (Show,Read,Eq,Ord) + +instance A.ToJSON (LspId m) where + toJSON (IdInt i) = A.toJSON i + toJSON (IdString s) = A.toJSON s + +instance A.FromJSON (LspId m) where + parseJSON v@(A.Number _) = IdInt <$> A.parseJSON v + parseJSON (A.String s) = return (IdString s) + parseJSON _ = mempty + +instance IxOrd LspId where + type Base LspId = Either Int Text + toBase (IdInt i) = Left i + toBase (IdString s) = Right s + +data SomeLspId where + SomeLspId :: LspId m -> SomeLspId + +deriving instance Show SomeLspId +instance Eq SomeLspId where + SomeLspId a == SomeLspId b = toBase a == toBase b diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 9c94614cb..f4ef0ec79 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -1,291 +1,258 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + module Language.Haskell.LSP.Types.Message where -import qualified Data.Aeson as A -import Data.Aeson.TH -import Data.Aeson.Types -import Data.Hashable --- For <= 8.2.2 -import Data.Text (Text) +import Language.Haskell.LSP.Types.DataTypesJSON +import Language.Haskell.LSP.Types.CodeAction +import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Constants - - --- | Id used for a request, Can be either a String or an Int -data LspId = IdInt Int | IdString Text - deriving (Show,Read,Eq,Ord) - -instance A.ToJSON LspId where - toJSON (IdInt i) = toJSON i - toJSON (IdString s) = toJSON s - -instance A.FromJSON LspId where - parseJSON v@(A.Number _) = IdInt <$> parseJSON v - parseJSON (A.String s) = return (IdString s) - parseJSON _ = mempty - -instance Hashable LspId where - hashWithSalt salt (IdInt i) = hashWithSalt salt i - hashWithSalt salt (IdString s) = hashWithSalt salt s +import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Hover +import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.LspId +import Language.Haskell.LSP.Types.Method +import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Window +import Language.Haskell.LSP.Types.WorkspaceEdit +import Language.Haskell.LSP.Types.WorkspaceFolders +import qualified Data.HashMap.Strict as HM + +import Data.Kind +import Data.Aeson +import Data.Aeson.Types +import Data.Aeson.TH +import Data.Text (Text) +import Data.Function (on) +import GHC.Generics -- --------------------------------------------------------------------- - --- | Id used for a response, Can be either a String or an Int, or Null. If a --- request doesn't provide a result value the receiver of a request still needs --- to return a response message to conform to the JSON RPC specification. The --- result property of the ResponseMessage should be set to null in this case to --- signal a successful request. -data LspIdRsp = IdRspInt Int | IdRspString Text | IdRspNull - deriving (Show,Read,Eq) - -instance A.ToJSON LspIdRsp where - toJSON (IdRspInt i) = toJSON i - toJSON (IdRspString s) = toJSON s - toJSON IdRspNull = A.Null - -instance A.FromJSON LspIdRsp where - parseJSON v@(A.Number _) = IdRspInt <$> parseJSON v - parseJSON (A.String s) = return $ IdRspString s - parseJSON A.Null = return IdRspNull - parseJSON _ = mempty - -instance Hashable LspIdRsp where - hashWithSalt salt (IdRspInt i) = hashWithSalt salt i - hashWithSalt salt (IdRspString s) = hashWithSalt salt s - hashWithSalt _ IdRspNull = 0 - --- | Converts an LspId to its LspIdRsp counterpart. -responseId :: LspId -> LspIdRsp -responseId (IdInt i) = IdRspInt i -responseId (IdString s) = IdRspString s - --- | Converts an LspIdRsp to its LspId counterpart. -requestId :: LspIdRsp -> LspId -requestId (IdRspInt i) = IdInt i -requestId (IdRspString s) = IdString s -requestId IdRspNull = error "Null response id" - +-- PARAMS definition +-- Map Methods to params/responses -- --------------------------------------------------------------------- --- Client Methods -data ClientMethod = - -- General - Initialize - | Initialized - | Shutdown - | Exit - | CancelRequest - -- Workspace - | WorkspaceDidChangeWorkspaceFolders - | WorkspaceDidChangeConfiguration - | WorkspaceDidChangeWatchedFiles - | WorkspaceSymbol - | WorkspaceExecuteCommand - -- Progress - | WorkDoneProgressCancel - -- Document - | TextDocumentDidOpen - | TextDocumentDidChange - | TextDocumentWillSave - | TextDocumentWillSaveWaitUntil - | TextDocumentDidSave - | TextDocumentDidClose - | TextDocumentCompletion - | CompletionItemResolve - | TextDocumentHover - | TextDocumentSignatureHelp - | TextDocumentDefinition - | TextDocumentTypeDefinition - | TextDocumentImplementation - | TextDocumentReferences - | TextDocumentDocumentHighlight - | TextDocumentDocumentSymbol - | TextDocumentCodeAction - | TextDocumentCodeLens - | CodeLensResolve - | TextDocumentDocumentLink - | DocumentLinkResolve - | TextDocumentDocumentColor - | TextDocumentColorPresentation - | TextDocumentFormatting - | TextDocumentRangeFormatting - | TextDocumentOnTypeFormatting - | TextDocumentRename - | TextDocumentPrepareRename - | TextDocumentFoldingRange - -- A custom message type. It is not enforced that this starts with $/. - | CustomClientMethod Text - deriving (Eq,Ord,Read,Show) - -instance A.FromJSON ClientMethod where - -- General - parseJSON (A.String "initialize") = return Initialize - parseJSON (A.String "initialized") = return Initialized - parseJSON (A.String "shutdown") = return Shutdown - parseJSON (A.String "exit") = return Exit - parseJSON (A.String "$/cancelRequest") = return CancelRequest - -- Workspace - parseJSON (A.String "workspace/didChangeWorkspaceFolders") = return WorkspaceDidChangeWorkspaceFolders - parseJSON (A.String "workspace/didChangeConfiguration") = return WorkspaceDidChangeConfiguration - parseJSON (A.String "workspace/didChangeWatchedFiles") = return WorkspaceDidChangeWatchedFiles - parseJSON (A.String "workspace/symbol") = return WorkspaceSymbol - parseJSON (A.String "workspace/executeCommand") = return WorkspaceExecuteCommand - -- Document - parseJSON (A.String "textDocument/didOpen") = return TextDocumentDidOpen - parseJSON (A.String "textDocument/didChange") = return TextDocumentDidChange - parseJSON (A.String "textDocument/willSave") = return TextDocumentWillSave - parseJSON (A.String "textDocument/willSaveWaitUntil") = return TextDocumentWillSaveWaitUntil - parseJSON (A.String "textDocument/didSave") = return TextDocumentDidSave - parseJSON (A.String "textDocument/didClose") = return TextDocumentDidClose - parseJSON (A.String "textDocument/completion") = return TextDocumentCompletion - parseJSON (A.String "completionItem/resolve") = return CompletionItemResolve - parseJSON (A.String "textDocument/hover") = return TextDocumentHover - parseJSON (A.String "textDocument/signatureHelp") = return TextDocumentSignatureHelp - parseJSON (A.String "textDocument/definition") = return TextDocumentDefinition - parseJSON (A.String "textDocument/typeDefinition") = return TextDocumentTypeDefinition - parseJSON (A.String "textDocument/implementation") = return TextDocumentImplementation - parseJSON (A.String "textDocument/references") = return TextDocumentReferences - parseJSON (A.String "textDocument/documentHighlight") = return TextDocumentDocumentHighlight - parseJSON (A.String "textDocument/documentSymbol") = return TextDocumentDocumentSymbol - parseJSON (A.String "textDocument/codeAction") = return TextDocumentCodeAction - parseJSON (A.String "textDocument/codeLens") = return TextDocumentCodeLens - parseJSON (A.String "codeLens/resolve") = return CodeLensResolve - parseJSON (A.String "textDocument/documentLink") = return TextDocumentDocumentLink - parseJSON (A.String "documentLink/resolve") = return DocumentLinkResolve - parseJSON (A.String "textDocument/documentColor") = return TextDocumentDocumentColor - parseJSON (A.String "textDocument/colorPresentation") = return TextDocumentColorPresentation - parseJSON (A.String "textDocument/formatting") = return TextDocumentFormatting - parseJSON (A.String "textDocument/rangeFormatting") = return TextDocumentRangeFormatting - parseJSON (A.String "textDocument/onTypeFormatting") = return TextDocumentOnTypeFormatting - parseJSON (A.String "textDocument/rename") = return TextDocumentRename - parseJSON (A.String "textDocument/prepareRename") = return TextDocumentPrepareRename - parseJSON (A.String "textDocument/foldingRange") = return TextDocumentFoldingRange - parseJSON (A.String "window/workDoneProgress/cancel") = return WorkDoneProgressCancel - parseJSON (A.String x) = return (CustomClientMethod x) - parseJSON _ = mempty - -instance A.ToJSON ClientMethod where +-- | Map a method to the message payload type +type family MessageParams (m :: Method p t) :: Type where +-- Client -- General - toJSON Initialize = A.String "initialize" - toJSON Initialized = A.String "initialized" - toJSON Shutdown = A.String "shutdown" - toJSON Exit = A.String "exit" - toJSON CancelRequest = A.String "$/cancelRequest" + MessageParams Initialize = InitializeParams + MessageParams Initialized = Maybe InitializedParams + MessageParams Shutdown = Maybe Value + MessageParams Exit = Maybe ExitParams -- Workspace - toJSON WorkspaceDidChangeWorkspaceFolders = A.String "workspace/didChangeWorkspaceFolders" - toJSON WorkspaceDidChangeConfiguration = A.String "workspace/didChangeConfiguration" - toJSON WorkspaceDidChangeWatchedFiles = A.String "workspace/didChangeWatchedFiles" - toJSON WorkspaceSymbol = A.String "workspace/symbol" - toJSON WorkspaceExecuteCommand = A.String "workspace/executeCommand" - -- Document - toJSON TextDocumentDidOpen = A.String "textDocument/didOpen" - toJSON TextDocumentDidChange = A.String "textDocument/didChange" - toJSON TextDocumentWillSave = A.String "textDocument/willSave" - toJSON TextDocumentWillSaveWaitUntil = A.String "textDocument/willSaveWaitUntil" - toJSON TextDocumentDidSave = A.String "textDocument/didSave" - toJSON TextDocumentDidClose = A.String "textDocument/didClose" - toJSON TextDocumentCompletion = A.String "textDocument/completion" - toJSON CompletionItemResolve = A.String "completionItem/resolve" - toJSON TextDocumentHover = A.String "textDocument/hover" - toJSON TextDocumentSignatureHelp = A.String "textDocument/signatureHelp" - toJSON TextDocumentReferences = A.String "textDocument/references" - toJSON TextDocumentDocumentHighlight = A.String "textDocument/documentHighlight" - toJSON TextDocumentDocumentSymbol = A.String "textDocument/documentSymbol" - toJSON TextDocumentDefinition = A.String "textDocument/definition" - toJSON TextDocumentTypeDefinition = A.String "textDocument/typeDefinition" - toJSON TextDocumentImplementation = A.String "textDocument/implementation" - toJSON TextDocumentCodeAction = A.String "textDocument/codeAction" - toJSON TextDocumentCodeLens = A.String "textDocument/codeLens" - toJSON CodeLensResolve = A.String "codeLens/resolve" - toJSON TextDocumentDocumentColor = A.String "textDocument/documentColor" - toJSON TextDocumentColorPresentation = A.String "textDocument/colorPresentation" - toJSON TextDocumentFormatting = A.String "textDocument/formatting" - toJSON TextDocumentRangeFormatting = A.String "textDocument/rangeFormatting" - toJSON TextDocumentOnTypeFormatting = A.String "textDocument/onTypeFormatting" - toJSON TextDocumentRename = A.String "textDocument/rename" - toJSON TextDocumentPrepareRename = A.String "textDocument/prepareRename" - toJSON TextDocumentFoldingRange = A.String "textDocument/foldingRange" - toJSON TextDocumentDocumentLink = A.String "textDocument/documentLink" - toJSON DocumentLinkResolve = A.String "documentLink/resolve" - toJSON WorkDoneProgressCancel = A.String "window/workDoneProgress/cancel" - toJSON (CustomClientMethod xs) = A.String xs - -data ServerMethod = - -- Window - WindowShowMessage - | WindowShowMessageRequest - | WindowLogMessage - | WindowWorkDoneProgressCreate - | Progress - | TelemetryEvent - -- Client - | ClientRegisterCapability - | ClientUnregisterCapability + MessageParams WorkspaceDidChangeWorkspaceFolders = DidChangeWorkspaceFoldersParams + MessageParams WorkspaceDidChangeConfiguration = DidChangeConfigurationParams + MessageParams WorkspaceDidChangeWatchedFiles = DidChangeWatchedFilesParams + MessageParams WorkspaceSymbol = WorkspaceSymbolParams + MessageParams WorkspaceExecuteCommand = ExecuteCommandParams + -- Progress + MessageParams WorkDoneProgressCancel = WorkDoneProgressCancelParams + -- Sync/Document state + MessageParams TextDocumentDidOpen = DidOpenTextDocumentParams + MessageParams TextDocumentDidChange = DidChangeTextDocumentParams + MessageParams TextDocumentWillSave = WillSaveTextDocumentParams + MessageParams TextDocumentWillSaveWaitUntil = WillSaveTextDocumentParams + MessageParams TextDocumentDidSave = DidSaveTextDocumentParams + MessageParams TextDocumentDidClose = DidCloseTextDocumentParams + -- Completion + MessageParams TextDocumentCompletion = CompletionParams + MessageParams CompletionItemResolve = CompletionItem + -- Language Queries + MessageParams TextDocumentHover = TextDocumentPositionParams + MessageParams TextDocumentSignatureHelp = TextDocumentPositionParams + MessageParams TextDocumentDefinition = TextDocumentPositionParams + MessageParams TextDocumentTypeDefinition = TextDocumentPositionParams + MessageParams TextDocumentImplementation = TextDocumentPositionParams + MessageParams TextDocumentReferences = ReferenceParams + MessageParams TextDocumentDocumentHighlight = TextDocumentPositionParams + MessageParams TextDocumentDocumentSymbol = DocumentSymbolParams + -- Code Action/Lens/Link + MessageParams TextDocumentCodeAction = CodeActionParams + MessageParams TextDocumentCodeLens = CodeLensParams + MessageParams CodeLensResolve = CodeLens + MessageParams TextDocumentDocumentLink = DocumentLinkParams + MessageParams DocumentLinkResolve = DocumentLink + -- Syntax highlighting/coloring + MessageParams TextDocumentDocumentColor = DocumentColorParams + MessageParams TextDocumentColorPresentation = ColorPresentationParams + -- Formatting + MessageParams TextDocumentFormatting = DocumentFormattingParams + MessageParams TextDocumentRangeFormatting = DocumentRangeFormattingParams + MessageParams TextDocumentOnTypeFormatting = DocumentOnTypeFormattingParams + -- Rename + MessageParams TextDocumentRename = RenameParams + MessageParams TextDocumentPrepareRename = TextDocumentPositionParams + -- FoldingRange + MessageParams TextDocumentFoldingRange = FoldingRangeParams +-- Server + -- Window + MessageParams WindowShowMessage = ShowMessageParams + MessageParams WindowShowMessageRequest = ShowMessageRequestParams + MessageParams WindowLogMessage = LogMessageParams + MessageParams WindowWorkDoneProgressCreate = WorkDoneProgressCreateParams + MessageParams Progress = ProgressParams SomeProgressParams + MessageParams TelemetryEvent = Value + -- Capability + MessageParams ClientRegisterCapability = RegistrationParams + MessageParams ClientUnregisterCapability = UnregistrationParams -- Workspace - | WorkspaceWorkspaceFolders - | WorkspaceConfiguration - | WorkspaceApplyEdit - -- Document - | TextDocumentPublishDiagnostics - -- Cancelling - | CancelRequestServer - | CustomServerMethod Text - deriving (Eq,Ord,Read,Show) - -instance A.FromJSON ServerMethod where - -- Window - parseJSON (A.String "window/showMessage") = return WindowShowMessage - parseJSON (A.String "window/showMessageRequest") = return WindowShowMessageRequest - parseJSON (A.String "window/logMessage") = return WindowLogMessage - parseJSON (A.String "window/workDoneProgress/create") = return WindowWorkDoneProgressCreate - parseJSON (A.String "$/progress") = return Progress - parseJSON (A.String "telemetry/event") = return TelemetryEvent - -- Client - parseJSON (A.String "client/registerCapability") = return ClientRegisterCapability - parseJSON (A.String "client/unregisterCapability") = return ClientUnregisterCapability + MessageParams WorkspaceWorkspaceFolders = Empty + MessageParams WorkspaceConfiguration = ConfigurationParams + MessageParams WorkspaceApplyEdit = ApplyWorkspaceEditParams + -- Document/Diagnostic + MessageParams TextDocumentPublishDiagnostics = PublishDiagnosticsParams + -- Cancel + MessageParams CancelRequest = CancelParams + -- Custom + MessageParams CustomMethod = Value + +-- | Map a request method to the response payload type +type family ResponseParams (m :: Method p Request) :: Type where +-- Client + -- General + ResponseParams Initialize = InitializeResponseCapabilities + ResponseParams Shutdown = Empty -- Workspace - parseJSON (A.String "workspace/workspaceFolders") = return WorkspaceWorkspaceFolders - parseJSON (A.String "workspace/configuration") = return WorkspaceConfiguration - parseJSON (A.String "workspace/applyEdit") = return WorkspaceApplyEdit - -- Document - parseJSON (A.String "textDocument/publishDiagnostics") = return TextDocumentPublishDiagnostics - -- Cancelling - parseJSON (A.String "$/cancelRequest") = return CancelRequestServer - parseJSON (A.String m) = return (CustomServerMethod m) - parseJSON _ = mempty - -instance A.ToJSON ServerMethod where + ResponseParams WorkspaceSymbol = List SymbolInformation + ResponseParams WorkspaceExecuteCommand = Value + -- Sync/Document state + ResponseParams TextDocumentWillSaveWaitUntil = List TextEdit + -- Completion + ResponseParams TextDocumentCompletion = CompletionResponseResult + ResponseParams CompletionItemResolve = CompletionItem + -- Language Queries + ResponseParams TextDocumentHover = Maybe Hover + ResponseParams TextDocumentSignatureHelp = SignatureHelp + ResponseParams TextDocumentDefinition = LocationResponseParams + ResponseParams TextDocumentTypeDefinition = LocationResponseParams + ResponseParams TextDocumentImplementation = LocationResponseParams + ResponseParams TextDocumentReferences = List Location + ResponseParams TextDocumentDocumentHighlight = List DocumentHighlight + ResponseParams TextDocumentDocumentSymbol = DSResult + -- Code Action/Lens/Link + ResponseParams TextDocumentCodeAction = List CAResult + ResponseParams TextDocumentCodeLens = List CodeLens + ResponseParams CodeLensResolve = CodeLens + ResponseParams TextDocumentDocumentLink = List DocumentLink + ResponseParams DocumentLinkResolve = DocumentLink + -- Syntax highlighting/coloring + ResponseParams TextDocumentDocumentColor = List ColorInformation + ResponseParams TextDocumentColorPresentation = List ColorPresentation + -- Formatting + ResponseParams TextDocumentFormatting = List TextEdit + ResponseParams TextDocumentRangeFormatting = List TextEdit + ResponseParams TextDocumentOnTypeFormatting = List TextEdit + -- Rename + ResponseParams TextDocumentRename = WorkspaceEdit + ResponseParams TextDocumentPrepareRename = Maybe RangeOrRangeWithPlaceholder + -- FoldingRange + ResponseParams TextDocumentFoldingRange = List FoldingRange + -- Custom can be either a notification or a message +-- Server -- Window - toJSON WindowShowMessage = A.String "window/showMessage" - toJSON WindowShowMessageRequest = A.String "window/showMessageRequest" - toJSON WindowLogMessage = A.String "window/logMessage" - toJSON WindowWorkDoneProgressCreate = A.String "window/workDoneProgress/create" - toJSON Progress = A.String "$/progress" - toJSON TelemetryEvent = A.String "telemetry/event" - -- Client - toJSON ClientRegisterCapability = A.String "client/registerCapability" - toJSON ClientUnregisterCapability = A.String "client/unregisterCapability" + ResponseParams WindowShowMessageRequest = Maybe MessageActionItem + ResponseParams WindowWorkDoneProgressCreate = () + -- Capability + ResponseParams ClientRegisterCapability = Empty + ResponseParams ClientUnregisterCapability = Empty -- Workspace - toJSON WorkspaceWorkspaceFolders = A.String "workspace/workspaceFolders" - toJSON WorkspaceConfiguration = A.String "workspace/configuration" - toJSON WorkspaceApplyEdit = A.String "workspace/applyEdit" - -- Document - toJSON TextDocumentPublishDiagnostics = A.String "textDocument/publishDiagnostics" - -- Cancelling - toJSON CancelRequestServer = A.String "$/cancelRequest" - toJSON (CustomServerMethod m) = A.String m - -data RequestMessage m req resp = - RequestMessage + ResponseParams WorkspaceWorkspaceFolders = Maybe (List WorkspaceFolder) + ResponseParams WorkspaceConfiguration = List Value + ResponseParams WorkspaceApplyEdit = ApplyWorkspaceEditResponseBody +-- Custom + ResponseParams CustomMethod = Value + +data Empty = Empty deriving (Eq,Ord,Show) +instance ToJSON Empty where + toJSON Empty = Null +instance FromJSON Empty where + parseJSON Null = pure Empty + parseJSON _ = mempty + + +-- --------------------------------------------------------------------- +{- +$ Notifications and Requests + +Notification and requests ids starting with '$/' are messages which are protocol +implementation dependent and might not be implementable in all clients or +servers. For example if the server implementation uses a single threaded +synchronous programming language then there is little a server can do to react +to a '$/cancelRequest'. If a server or client receives notifications or requests +starting with '$/' it is free to ignore them if they are unknown. + +-} + +data NotificationMessage (m :: Method p Notification) = + NotificationMessage { _jsonrpc :: Text - , _id :: LspId - , _method :: m - , _params :: req - } deriving (Read,Show,Eq) + , _method :: SMethod m + , _params :: MessageParams m + } deriving Generic + +deriving instance Eq (MessageParams m) => Eq (NotificationMessage m) +deriving instance Show (MessageParams m) => Show (NotificationMessage m) -deriveJSON lspOptions ''RequestMessage +instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (NotificationMessage m) where + parseJSON = genericParseJSON lspOptions +instance (ToJSON (MessageParams m)) => ToJSON (NotificationMessage m) where + toJSON = genericToJSON lspOptions + toEncoding = genericToEncoding lspOptions +data RequestMessage (m :: Method p Request) = RequestMessage + { _jsonrpc :: Text + , _id :: LspId m + , _method :: SMethod m + , _params :: MessageParams m + } deriving Generic + +deriving instance Eq (MessageParams m) => Eq (RequestMessage m) +deriving instance (Read (SMethod m), Read (MessageParams m)) => Read (RequestMessage m) +deriving instance Show (MessageParams m) => Show (RequestMessage m) + +instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (RequestMessage m) where + parseJSON = genericParseJSON lspOptions +instance (ToJSON (MessageParams m), FromJSON (SMethod m)) => ToJSON (RequestMessage m) where + toJSON = genericToJSON lspOptions + toEncoding = genericToEncoding lspOptions + +-- | A custom message data type is needed to distinguish between +-- notifications and requests, since a CustomMethod can be both! +data CustomMessage p t where + ReqMess :: RequestMessage (CustomMethod :: Method p Request) -> CustomMessage p Request + NotMess :: NotificationMessage (CustomMethod :: Method p Notification) -> CustomMessage p Notification + +deriving instance Show (CustomMessage p t) + +instance ToJSON (CustomMessage p t) where + toJSON (ReqMess a) = toJSON a + toJSON (NotMess a) = toJSON a + +instance FromJSON (CustomMessage p Request) where + parseJSON v = ReqMess <$> parseJSON v +instance FromJSON (CustomMessage p Notification) where + parseJSON v = NotMess <$> parseJSON v + +-- --------------------------------------------------------------------- +-- Response Message -- --------------------------------------------------------------------- {- interface ResponseError { @@ -338,31 +305,31 @@ data ErrorCode = ParseError -- ^ Note: server error codes are reserved from -32099 to -32000 deriving (Read,Show,Eq) -instance A.ToJSON ErrorCode where - toJSON ParseError = A.Number (-32700) - toJSON InvalidRequest = A.Number (-32600) - toJSON MethodNotFound = A.Number (-32601) - toJSON InvalidParams = A.Number (-32602) - toJSON InternalError = A.Number (-32603) - toJSON ServerErrorStart = A.Number (-32099) - toJSON ServerErrorEnd = A.Number (-32000) - toJSON ServerNotInitialized = A.Number (-32002) - toJSON UnknownErrorCode = A.Number (-32001) - toJSON RequestCancelled = A.Number (-32800) - toJSON ContentModified = A.Number (-32801) - -instance A.FromJSON ErrorCode where - parseJSON (A.Number (-32700)) = pure ParseError - parseJSON (A.Number (-32600)) = pure InvalidRequest - parseJSON (A.Number (-32601)) = pure MethodNotFound - parseJSON (A.Number (-32602)) = pure InvalidParams - parseJSON (A.Number (-32603)) = pure InternalError - parseJSON (A.Number (-32099)) = pure ServerErrorStart - parseJSON (A.Number (-32000)) = pure ServerErrorEnd - parseJSON (A.Number (-32002)) = pure ServerNotInitialized - parseJSON (A.Number (-32001)) = pure UnknownErrorCode - parseJSON (A.Number (-32800)) = pure RequestCancelled - parseJSON (A.Number (-32801)) = pure ContentModified +instance ToJSON ErrorCode where + toJSON ParseError = Number (-32700) + toJSON InvalidRequest = Number (-32600) + toJSON MethodNotFound = Number (-32601) + toJSON InvalidParams = Number (-32602) + toJSON InternalError = Number (-32603) + toJSON ServerErrorStart = Number (-32099) + toJSON ServerErrorEnd = Number (-32000) + toJSON ServerNotInitialized = Number (-32002) + toJSON UnknownErrorCode = Number (-32001) + toJSON RequestCancelled = Number (-32800) + toJSON ContentModified = Number (-32801) + +instance FromJSON ErrorCode where + parseJSON (Number (-32700)) = pure ParseError + parseJSON (Number (-32600)) = pure InvalidRequest + parseJSON (Number (-32601)) = pure MethodNotFound + parseJSON (Number (-32602)) = pure InvalidParams + parseJSON (Number (-32603)) = pure InternalError + parseJSON (Number (-32099)) = pure ServerErrorStart + parseJSON (Number (-32000)) = pure ServerErrorEnd + parseJSON (Number (-32002)) = pure ServerNotInitialized + parseJSON (Number (-32001)) = pure UnknownErrorCode + parseJSON (Number (-32800)) = pure RequestCancelled + parseJSON (Number (-32801)) = pure ContentModified parseJSON _ = mempty -- ------------------------------------- @@ -393,43 +360,24 @@ data ResponseError = ResponseError { _code :: ErrorCode , _message :: Text - , _xdata :: Maybe A.Value + , _xdata :: Maybe Value } deriving (Read,Show,Eq) deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ResponseError --- --------------------------------------------------------------------- - -{- - https://microsoft.github.io/language-server-protocol/specification#responseMessage - - interface ResponseMessage extends Message { - /** - * The request id. - */ - id: number | string | null; - - /** - * The result of a request. This member is REQUIRED on success. - * This member MUST NOT exist if there was an error invoking the method. - */ - result?: string | number | boolean | object | null; - - /** - * The error object in case a request fails. - */ - error?: ResponseError; - } --} - -data ResponseMessage a = +-- | Either result or error must be Just. +data ResponseMessage (m :: Method p Request) = ResponseMessage { _jsonrpc :: Text - , _id :: LspIdRsp - , _result :: Either ResponseError a - } deriving (Read,Show,Eq) + , _id :: Maybe (LspId m) + , _result :: Either ResponseError (ResponseParams m) + } deriving Generic + +deriving instance Eq (ResponseParams m) => Eq (ResponseMessage m) +deriving instance Read (ResponseParams m) => Read (ResponseMessage m) +deriving instance Show (ResponseParams m) => Show (ResponseMessage m) -instance ToJSON a => ToJSON (ResponseMessage a) where +instance (ToJSON (ResponseParams m)) => ToJSON (ResponseMessage m) where toJSON (ResponseMessage { _jsonrpc = jsonrpc, _id = lspid, _result = result }) = object [ "jsonrpc" .= jsonrpc @@ -439,7 +387,7 @@ instance ToJSON a => ToJSON (ResponseMessage a) where Right a -> "result" .= a ] -instance FromJSON a => FromJSON (ResponseMessage a) where +instance FromJSON (ResponseParams a) => FromJSON (ResponseMessage a) where parseJSON = withObject "Response" $ \o -> do _jsonrpc <- o .: "jsonrpc" _id <- o .: "id" @@ -449,73 +397,276 @@ instance FromJSON a => FromJSON (ResponseMessage a) where result <- case (_error, _result) of ((Just err), Nothing ) -> pure $ Left err (Nothing , (Just res)) -> pure $ Right res - ((Just _), (Just _)) -> fail $ "Both error and result cannot be present" - (Nothing, Nothing) -> fail "Both error and result cannot be Nothing" + ((Just _err), (Just _res)) -> fail $ "both error and result cannot be present: " ++ show o + (Nothing, Nothing) -> fail "both error and result cannot be Nothing" return $ ResponseMessage _jsonrpc _id $ result -type ErrorResponse = ResponseMessage () - +-- --------------------------------------------------------------------- +-- Helper Type Families -- --------------------------------------------------------------------- -type BareResponseMessage = ResponseMessage A.Value +-- | Map a method to the Request/Notification type with the correct +-- payload +type family Message (m :: Method p t) :: Type where + Message (CustomMethod :: Method p t) = CustomMessage p t + Message (m :: Method p t) = BaseMessage t m + +type family BaseMessage (t :: MethodType) :: Method p t -> Type where + BaseMessage Request = RequestMessage + BaseMessage Notification = NotificationMessage + +type HandlerFunc a = Either ResponseError a -> IO () + +-- | Map a method to a handler for its response +-- Either ResponseError (ResponseParams m) -> IO () for Requests +-- () for Notifications +-- This is a callback that will be invoked when your request +-- recieves a response +-- Custom methods can either be a notification or a request, so +-- it may or may not have a response handler! +type family ResponseHandlerFunc m :: Type where + ResponseHandlerFunc (m :: Method p t) = BaseHandlerFunc t m + +type family BaseHandlerFunc (t :: MethodType) (m :: Method p t) :: Type where + BaseHandlerFunc Request m = HandlerFunc (ResponseParams m) + BaseHandlerFunc Notification m = () + +-- Some helpful type synonyms +type ClientMessage (m :: Method FromClient t) = Message m +type ServerMessage (m :: Method FromServer t) = Message m +type SClientMethod (m :: Method FromClient t) = SMethod m +type SServerMethod (m :: Method FromServer t) = SMethod m -- --------------------------------------------------------------------- -{- -$ Notifications and Requests +-- Working with arbritary messages +-- --------------------------------------------------------------------- -Notification and requests ids starting with '$/' are messages which are protocol -implementation dependent and might not be implementable in all clients or -servers. For example if the server implementation uses a single threaded -synchronous programming language then there is little a server can do to react -to a '$/cancelRequest'. If a server or client receives notifications or requests -starting with '$/' it is free to ignore them if they are unknown. --} +data FromServerMessage' a where + FromServerMess :: forall t (m :: Method FromServer t) a. SMethod m -> Message m -> FromServerMessage' a + FromServerRsp :: forall (m :: Method FromClient Request) a. a m -> ResponseMessage m -> FromServerMessage' a -data NotificationMessage m a = - NotificationMessage - { _jsonrpc :: Text - , _method :: m - , _params :: a - } deriving (Read,Show,Eq) +type FromServerMessage = FromServerMessage' SMethod -deriveJSON lspOptions ''NotificationMessage +instance Eq FromServerMessage where + (==) = (==) `on` toJSON +instance Show FromServerMessage where + show = show . toJSON --- --------------------------------------------------------------------- -{- -Cancellation Support +instance ToJSON FromServerMessage where + toJSON (FromServerMess m p) = serverMethodJSON m (toJSON p) + toJSON (FromServerRsp m p) = clientResponseJSON m (toJSON p) -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#cancellation-support +fromServerNot :: forall (m :: Method FromServer Notification). + Message m ~ NotificationMessage m => NotificationMessage m -> FromServerMessage +fromServerNot m@NotificationMessage{_method=meth} = FromServerMess meth m - New: The base protocol now offers support for request cancellation. To - cancel a request, a notification message with the following properties is - sent: +fromServerReq :: forall (m :: Method FromServer Request). + Message m ~ RequestMessage m => RequestMessage m -> FromServerMessage +fromServerReq m@RequestMessage{_method=meth} = FromServerMess meth m -Notification: +data FromClientMessage' a where + FromClientMess :: forall t (m :: Method FromClient t) a. SMethod m -> Message m -> FromClientMessage' a + FromClientRsp :: forall (m :: Method FromServer Request) a. a m -> ResponseMessage m -> FromClientMessage' a - method: '$/cancelRequest' - params: CancelParams defined as follows: +type FromClientMessage = FromClientMessage' SMethod -interface CancelParams { - /** - * The request id to cancel. - */ - id: number | string; -} +instance ToJSON FromClientMessage where + toJSON (FromClientMess m p) = clientMethodJSON m (toJSON p) + toJSON (FromClientRsp m p) = serverResponseJSON m (toJSON p) -A request that got canceled still needs to return from the server and send a -response back. It can not be left open / hanging. This is in line with the JSON -RPC protocol that requires that every request sends a response back. In addition -it allows for returning partial results on cancel. --} +fromClientNot :: forall (m :: Method FromClient Notification). + Message m ~ NotificationMessage m => NotificationMessage m -> FromClientMessage +fromClientNot m@NotificationMessage{_method=meth} = FromClientMess meth m -data CancelParams = - CancelParams - { _id :: LspId - } deriving (Read,Show,Eq) +fromClientReq :: forall (m :: Method FromClient Request). + Message m ~ RequestMessage m => RequestMessage m -> FromClientMessage +fromClientReq m@RequestMessage{_method=meth} = FromClientMess meth m -deriveJSON lspOptions ''CancelParams +type LookupFunc p a = forall (m :: Method p Request). LspId m -> Maybe (SMethod m, a m) -type CancelNotification = NotificationMessage ClientMethod CancelParams -type CancelNotificationServer = NotificationMessage ServerMethod CancelParams +{- +Message Types we must handle are the following + +Request | jsonrpc | id | method | params? +Response | jsonrpc | id | | | response? | error? +Notification | jsonrpc | | method | params? +-} + +parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMessage' a) +parseServerMessage lookupId v@(Object o) = do + case HM.lookup "method" o of + Just cmd -> do + -- Request or Response + sm <- parseJSON cmd + case sm of + SomeServerMethod m -> case splitServerMethod m of + IsServerNot -> FromServerMess m <$> parseJSON v + IsServerReq -> FromServerMess m <$> parseJSON v + IsServerEither + | HM.member "id" o -- Request + , SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request)) + in FromServerMess m' <$> parseJSON v + | SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification)) + in FromServerMess m' <$> parseJSON v + Nothing -> do + case HM.lookup "id" o of + Just i' -> do + i <- parseJSON i' + case lookupId i of + Just (m,res) -> clientResponseJSON m $ FromServerRsp res <$> parseJSON v + Nothing -> fail $ unwords ["Failed in looking up response type of", show v] + Nothing -> fail $ unwords ["Got unexpected message without method or id"] +parseServerMessage _ v = fail $ unwords ["parseServerMessage expected object, got:",show v] + +parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMessage' a) +parseClientMessage lookupId v@(Object o) = do + case HM.lookup "method" o of + Just cmd -> do + -- Request or Response + sm <- parseJSON cmd + case sm of + SomeClientMethod m -> case splitClientMethod m of + IsClientNot -> FromClientMess m <$> parseJSON v + IsClientReq -> FromClientMess m <$> parseJSON v + IsClientEither + | HM.member "id" o -- Request + , SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request)) + in FromClientMess m' <$> parseJSON v + | SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification)) + in FromClientMess m' <$> parseJSON v + Nothing -> do + case HM.lookup "id" o of + Just i' -> do + i <- parseJSON i' + case lookupId i of + Just (m,res) -> serverResponseJSON m $ FromClientRsp res <$> parseJSON v + Nothing -> fail $ unwords ["Failed in looking up response type of", show v] + Nothing -> fail $ unwords ["Got unexpected message without method or id"] +parseClientMessage _ v = fail $ unwords ["parseClientMessage expected object, got:",show v] -- --------------------------------------------------------------------- +-- Helper Utilities +-- --------------------------------------------------------------------- + +clientResponseJSON :: SClientMethod m -> (HasJSON (ResponseMessage m) => x) -> x +clientResponseJSON m x = case splitClientMethod m of + IsClientReq -> x + IsClientEither -> x + +serverResponseJSON :: SServerMethod m -> (HasJSON (ResponseMessage m) => x) -> x +serverResponseJSON m x = case splitServerMethod m of + IsServerReq -> x + IsServerEither -> x + +clientMethodJSON :: SClientMethod m -> (ToJSON (ClientMessage m) => x) -> x +clientMethodJSON m x = + case splitClientMethod m of + IsClientNot -> x + IsClientReq -> x + IsClientEither -> x + +serverMethodJSON :: SServerMethod m -> (ToJSON (ServerMessage m) => x) -> x +serverMethodJSON m x = + case splitServerMethod m of + IsServerNot -> x + IsServerReq -> x + IsServerEither -> x + +type HasJSON a = (ToJSON a,FromJSON a,Eq a) + +-- Reify universal properties about Client/Server Messages + +data ClientNotOrReq (m :: Method FromClient t) where + IsClientNot + :: ( HasJSON (ClientMessage m) + , Message m ~ NotificationMessage m + , ResponseHandlerFunc m ~ ()) + => ClientNotOrReq (m :: Method FromClient Notification) + IsClientReq + :: forall (m :: Method FromClient Request). + ( HasJSON (ClientMessage m) + , HasJSON (ResponseMessage m) + , Message m ~ RequestMessage m + , ResponseHandlerFunc m ~ HandlerFunc (ResponseParams m)) + => ClientNotOrReq m + IsClientEither + :: ClientNotOrReq CustomMethod + +data ServerNotOrReq (m :: Method FromServer t) where + IsServerNot + :: ( HasJSON (ServerMessage m) + , Message m ~ NotificationMessage m + , ResponseHandlerFunc m ~ ()) + => ServerNotOrReq (m :: Method FromServer Notification) + IsServerReq + :: forall (m :: Method FromServer Request). + ( HasJSON (ServerMessage m) + , HasJSON (ResponseMessage m) + , Message m ~ RequestMessage m + , ResponseHandlerFunc m ~ HandlerFunc (ResponseParams m)) + => ServerNotOrReq m + IsServerEither + :: ServerNotOrReq CustomMethod + +splitClientMethod :: SClientMethod m -> ClientNotOrReq m +splitClientMethod SInitialize = IsClientReq +splitClientMethod SInitialized = IsClientNot +splitClientMethod SShutdown = IsClientReq +splitClientMethod SExit = IsClientNot +splitClientMethod SWorkspaceDidChangeWorkspaceFolders = IsClientNot +splitClientMethod SWorkspaceDidChangeConfiguration = IsClientNot +splitClientMethod SWorkspaceDidChangeWatchedFiles = IsClientNot +splitClientMethod SWorkspaceSymbol = IsClientReq +splitClientMethod SWorkspaceExecuteCommand = IsClientReq +splitClientMethod SWorkDoneProgressCancel = IsClientNot +splitClientMethod STextDocumentDidOpen = IsClientNot +splitClientMethod STextDocumentDidChange = IsClientNot +splitClientMethod STextDocumentWillSave = IsClientNot +splitClientMethod STextDocumentWillSaveWaitUntil = IsClientReq +splitClientMethod STextDocumentDidSave = IsClientNot +splitClientMethod STextDocumentDidClose = IsClientNot +splitClientMethod STextDocumentCompletion = IsClientReq +splitClientMethod SCompletionItemResolve = IsClientReq +splitClientMethod STextDocumentHover = IsClientReq +splitClientMethod STextDocumentSignatureHelp = IsClientReq +splitClientMethod STextDocumentDefinition = IsClientReq +splitClientMethod STextDocumentTypeDefinition = IsClientReq +splitClientMethod STextDocumentImplementation = IsClientReq +splitClientMethod STextDocumentReferences = IsClientReq +splitClientMethod STextDocumentDocumentHighlight = IsClientReq +splitClientMethod STextDocumentDocumentSymbol = IsClientReq +splitClientMethod STextDocumentCodeAction = IsClientReq +splitClientMethod STextDocumentCodeLens = IsClientReq +splitClientMethod SCodeLensResolve = IsClientReq +splitClientMethod STextDocumentDocumentLink = IsClientReq +splitClientMethod SDocumentLinkResolve = IsClientReq +splitClientMethod STextDocumentDocumentColor = IsClientReq +splitClientMethod STextDocumentColorPresentation = IsClientReq +splitClientMethod STextDocumentFormatting = IsClientReq +splitClientMethod STextDocumentRangeFormatting = IsClientReq +splitClientMethod STextDocumentOnTypeFormatting = IsClientReq +splitClientMethod STextDocumentRename = IsClientReq +splitClientMethod STextDocumentPrepareRename = IsClientReq +splitClientMethod STextDocumentFoldingRange = IsClientReq +splitClientMethod SCancelRequest = IsClientNot +splitClientMethod SCustomMethod{} = IsClientEither + +splitServerMethod :: SServerMethod m -> ServerNotOrReq m +splitServerMethod SWindowShowMessage = IsServerNot +splitServerMethod SWindowShowMessageRequest = IsServerReq +splitServerMethod SWindowLogMessage = IsServerNot +splitServerMethod SWindowWorkDoneProgressCreate = IsServerReq +splitServerMethod SProgress = IsServerNot +splitServerMethod STelemetryEvent = IsServerNot +splitServerMethod SClientRegisterCapability = IsServerReq +splitServerMethod SClientUnregisterCapability = IsServerReq +splitServerMethod SWorkspaceWorkspaceFolders = IsServerReq +splitServerMethod SWorkspaceConfiguration = IsServerReq +splitServerMethod SWorkspaceApplyEdit = IsServerReq +splitServerMethod STextDocumentPublishDiagnostics = IsServerNot +splitServerMethod SCancelRequest = IsServerNot +splitServerMethod SCustomMethod{} = IsServerEither diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs deleted file mode 100644 index c223e31e1..000000000 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.LSP.Types.MessageFuncs ( - -- * General - fmClientInitializeRequest - , fmClientInitializedNotification - , fmClientShutdownRequest - , fmClientExitNotification - , fmClientCancelNotification - - -- * Window - , fmServerShowMessageNotification - , fmServerShowMessageRequest - , fmServerLogMessageNotification - , fmServerWorkDoneProgressBeginNotification - , fmServerWorkDoneProgressReportNotification - , fmServerWorkDoneProgressEndNotification - , fmServerWorkDoneProgressCreateRequest - , fmServerTelemetryNotification - - -- * Client - , fmServerRegisterCapabilityRequest - , fmServerUnregisterCapabilityRequest - - -- * Workspace - , fmClientDidChangeConfigurationNotification - , fmClientDidChangeWatchedFilesNotification - , fmClientWorkspaceSymbolRequest - , fmClientExecuteCommandRequest - , fmServerApplyWorkspaceEditRequest - - -- * Document - , fmServerPublishDiagnosticsNotification - , fmClientDidOpenTextDocumentNotification - , fmClientDidChangeTextDocumentNotification - , fmClientWillSaveTextDocumentNotification - , fmClientWillSaveWaitUntilRequest - , fmClientDidSaveTextDocumentNotification - , fmClientDidCloseTextDocumentNotification - , fmClientCompletionRequest - , fmClientCompletionItemResolveRequest - , fmClientHoverRequest - , fmClientSignatureHelpRequest - , fmClientReferencesRequest - , fmClientDocumentHighlightRequest - , fmClientDocumentSymbolRequest - , fmClientDocumentFormattingRequest - , fmClientDocumentRangeFormattingRequest - , fmClientDocumentOnTypeFormattingRequest - , fmClientDefinitionRequest - , fmClientCodeActionRequest - , fmClientCodeLensRequest - , fmClientCodeLensResolveRequest - , fmClientDocumentLinkRequest - , fmClientDocumentLinkResolveRequest - , fmClientRenameRequest - , fmClientPrepareRenameRequest - ) where - -import qualified Data.Aeson as J -import Data.Text ( Text ) -import qualified Language.Haskell.LSP.Types as J - --- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} --- --------------------------------------------------------------------- - --- ---------------------------------------------------------------------- --- General --- ---------------------------------------------------------------------- - --- * :leftwards_arrow_with_hook: [initialize](#initialize) - -fmClientInitializeRequest :: J.LspId -> J.InitializeParams -> J.InitializeRequest -fmClientInitializeRequest rid params - = J.RequestMessage "2.0" rid J.Initialize params - --- ---------------------------------------------------------------------- --- * **New** :arrow_right: [initialized](#initialized) - --- | From 3.0 -fmClientInitializedNotification :: J.InitializedNotification -fmClientInitializedNotification = J.NotificationMessage "2.0" J.Initialized Nothing - --- ---------------------------------------------------------------------- --- * :leftwards_arrow_with_hook: [shutdown](#shutdown) - -fmClientShutdownRequest :: J.LspId -> Maybe J.Value -> J.ShutdownRequest -fmClientShutdownRequest rid params - = J.RequestMessage "2.0" rid J.Shutdown params - --- ---------------------------------------------------------------------- --- * :arrow_right: [exit](#exit) - -fmClientExitNotification :: J.ExitNotification -fmClientExitNotification = J.NotificationMessage "2.0" J.Exit Nothing - --- ---------------------------------------------------------------------- --- * :arrow_right: [$/cancelRequest](#cancelRequest) - -fmClientCancelNotification :: J.LspId -> J.CancelNotification -fmClientCancelNotification idToCancel - = J.NotificationMessage "2.0" J.CancelRequest (J.CancelParams idToCancel) - --- ---------------------------------------------------------------------- --- Window --- ---------------------------------------------------------------------- - --- * :arrow_left: [window/showMessage](#window_showMessage) - -fmServerShowMessageNotification :: J.MessageType -> Text -> J.ShowMessageNotification -fmServerShowMessageNotification mt msg - = J.NotificationMessage "2.0" J.WindowShowMessage (J.ShowMessageParams mt msg) - --- ---------------------------------------------------------------------- --- * :arrow_right_hook: [window/showMessageRequest](#window_showMessageRequest) - -fmServerShowMessageRequest :: J.LspId -> J.ShowMessageRequestParams -> J.ShowMessageRequest -fmServerShowMessageRequest rid params - = J.RequestMessage "2.0" rid J.WindowShowMessageRequest params - --- ---------------------------------------------------------------------- --- * :arrow_left: [window/logMessage](#window_logMessage) - -fmServerLogMessageNotification :: J.MessageType -> Text -> J.LogMessageNotification -fmServerLogMessageNotification mt msg - = J.NotificationMessage "2.0" J.WindowLogMessage (J.LogMessageParams mt msg) - --- ---------------------------------------------------------------------- - -fmServerWorkDoneProgressBeginNotification :: J.ProgressParams J.WorkDoneProgressBeginParams -> J.WorkDoneProgressBeginNotification -fmServerWorkDoneProgressBeginNotification params - = J.NotificationMessage "2.0" J.Progress params - --- ---------------------------------------------------------------------- - -fmServerWorkDoneProgressReportNotification :: J.ProgressParams J.WorkDoneProgressReportParams -> J.WorkDoneProgressReportNotification -fmServerWorkDoneProgressReportNotification params - = J.NotificationMessage "2.0" J.Progress params - --- ---------------------------------------------------------------------- - -fmServerWorkDoneProgressEndNotification :: J.ProgressParams J.WorkDoneProgressEndParams -> J.WorkDoneProgressEndNotification -fmServerWorkDoneProgressEndNotification params - = J.NotificationMessage "2.0" J.Progress params - -fmServerWorkDoneProgressCreateRequest :: J.LspId -> J.WorkDoneProgressCreateParams -> J.WorkDoneProgressCreateRequest -fmServerWorkDoneProgressCreateRequest rid params - = J.RequestMessage "2.0" rid J.WindowWorkDoneProgressCreate params - --- ---------------------------------------------------------------------- --- * :arrow_left: [telemetry/event](#telemetry_event) - -fmServerTelemetryNotification :: J.Value -> J.TelemetryNotification -fmServerTelemetryNotification params - = J.NotificationMessage "2.0" J.TelemetryEvent params - --- ---------------------------------------------------------------------- --- Client --- ---------------------------------------------------------------------- - --- * :arrow_right_hook: [client/registerCapability](#client_registerCapability) --- | from 3.0 -fmServerRegisterCapabilityRequest :: J.LspId -> J.RegistrationParams -> J.RegisterCapabilityRequest -fmServerRegisterCapabilityRequest rid params - = J.RequestMessage "2.0" rid J.ClientRegisterCapability params - --- * :arrow_right_hook: [client/unregisterCapability](#client_unregisterCapability) --- | from 3.0 -fmServerUnregisterCapabilityRequest :: J.LspId -> J.UnregistrationParams -> J.UnregisterCapabilityRequest -fmServerUnregisterCapabilityRequest rid params - = J.RequestMessage "2.0" rid J.ClientUnregisterCapability params - --- ---------------------------------------------------------------------- --- Workspace --- ---------------------------------------------------------------------- - --- * :arrow_right: [workspace/didChangeConfiguration](#workspace_didChangeConfiguration) -fmClientDidChangeConfigurationNotification :: J.DidChangeConfigurationParams -> J.DidChangeConfigurationNotification -fmClientDidChangeConfigurationNotification params - = J.NotificationMessage "2.0" J.WorkspaceDidChangeConfiguration params - --- * :arrow_right: [workspace/didChangeWatchedFiles](#workspace_didChangeWatchedFiles) -fmClientDidChangeWatchedFilesNotification :: J.DidChangeWatchedFilesParams -> J.DidChangeWatchedFilesNotification -fmClientDidChangeWatchedFilesNotification params - = J.NotificationMessage "2.0" J.WorkspaceDidChangeWatchedFiles params - --- * :leftwards_arrow_with_hook: [workspace/symbol](#workspace_symbol) -fmClientWorkspaceSymbolRequest :: J.LspId -> J.WorkspaceSymbolParams -> J.WorkspaceSymbolRequest -fmClientWorkspaceSymbolRequest rid params - = J.RequestMessage "2.0" rid J.WorkspaceSymbol params - --- * **New** :leftwards_arrow_with_hook: [workspace/executeCommand](#workspace_executeCommand) --- | From 3.0 -fmClientExecuteCommandRequest :: J.LspId -> J.ExecuteCommandParams -> J.ExecuteCommandRequest -fmClientExecuteCommandRequest rid params - = J.RequestMessage "2.0" rid J.WorkspaceExecuteCommand params - --- * **New** :arrow_right_hook: [workspace/applyEdit](#workspace_applyEdit) --- | From 3.0 -fmServerApplyWorkspaceEditRequest :: J.LspId -> J.ApplyWorkspaceEditParams -> J.ApplyWorkspaceEditRequest -fmServerApplyWorkspaceEditRequest rid params - = J.RequestMessage "2.0" rid J.WorkspaceApplyEdit params - --- ---------------------------------------------------------------------- - -- Document --- ---------------------------------------------------------------------- - --- * :arrow_left: [textDocument/publishDiagnostics](#textDocument_publishDiagnostics) -fmServerPublishDiagnosticsNotification :: J.PublishDiagnosticsParams -> J.PublishDiagnosticsNotification -fmServerPublishDiagnosticsNotification params - = J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params - --- * :arrow_right: [textDocument/didOpen](#textDocument_didOpen) -fmClientDidOpenTextDocumentNotification :: J.DidOpenTextDocumentParams -> J.DidOpenTextDocumentNotification -fmClientDidOpenTextDocumentNotification params - = J.NotificationMessage "2.0" J.TextDocumentDidOpen params - --- * :arrow_right: [textDocument/didChange](#textDocument_didChange) -fmClientDidChangeTextDocumentNotification :: J.DidChangeTextDocumentParams -> J.DidChangeTextDocumentNotification -fmClientDidChangeTextDocumentNotification params - = J.NotificationMessage "2.0" J.TextDocumentDidChange params - --- * :arrow_right: [textDocument/willSave](#textDocument_willSave) -fmClientWillSaveTextDocumentNotification :: J.WillSaveTextDocumentParams -> J.WillSaveTextDocumentNotification -fmClientWillSaveTextDocumentNotification params - = J.NotificationMessage "2.0" J.TextDocumentWillSave params - --- * **New** :leftwards_arrow_with_hook: [textDocument/willSaveWaitUntil](#textDocument_willSaveWaitUntil) --- | From 3.0 -fmClientWillSaveWaitUntilRequest :: J.LspId -> J.WillSaveTextDocumentParams -> J.WillSaveWaitUntilTextDocumentRequest -fmClientWillSaveWaitUntilRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentWillSaveWaitUntil params - --- * **New** :arrow_right: [textDocument/didSave](#textDocument_didSave) --- | 3.0 -fmClientDidSaveTextDocumentNotification :: J.DidSaveTextDocumentParams -> J.DidSaveTextDocumentNotification -fmClientDidSaveTextDocumentNotification params - = J.NotificationMessage "2.0" J.TextDocumentDidSave params - --- * :arrow_right: [textDocument/didClose](#textDocument_didClose) -fmClientDidCloseTextDocumentNotification :: J.DidCloseTextDocumentParams -> J.DidCloseTextDocumentNotification -fmClientDidCloseTextDocumentNotification params - = J.NotificationMessage "2.0" J.TextDocumentDidClose params - --- * :leftwards_arrow_with_hook: [textDocument/completion](#textDocument_completion) -fmClientCompletionRequest :: J.LspId -> J.CompletionParams -> J.CompletionRequest -fmClientCompletionRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentCompletion params - --- * :leftwards_arrow_with_hook: [completionItem/resolve](#completionItem_resolve) -fmClientCompletionItemResolveRequest :: J.LspId -> J.CompletionItem -> J.CompletionItemResolveRequest -fmClientCompletionItemResolveRequest rid params - = J.RequestMessage "2.0" rid J.CompletionItemResolve params - --- * :leftwards_arrow_with_hook: [textDocument/hover](#textDocument_hover) -fmClientHoverRequest :: J.LspId -> J.TextDocumentPositionParams -> J.HoverRequest -fmClientHoverRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentHover params - --- * :leftwards_arrow_with_hook: [textDocument/signatureHelp](#textDocument_signatureHelp) -fmClientSignatureHelpRequest :: J.LspId -> J.TextDocumentPositionParams -> J.SignatureHelpRequest -fmClientSignatureHelpRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentSignatureHelp params - --- * :leftwards_arrow_with_hook: [textDocument/references](#textDocument_references) -fmClientReferencesRequest :: J.LspId -> J.ReferenceParams -> J.ReferencesRequest -fmClientReferencesRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentReferences params - --- * :leftwards_arrow_with_hook: [textDocument/documentHighlight](#textDocument_documentHighlight) -fmClientDocumentHighlightRequest :: J.LspId -> J.TextDocumentPositionParams -> J.DocumentHighlightRequest -fmClientDocumentHighlightRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentDocumentHighlight params - --- * :leftwards_arrow_with_hook: [textDocument/documentSymbol](#textDocument_documentSymbol) -fmClientDocumentSymbolRequest :: J.LspId -> J.DocumentSymbolParams -> J.DocumentSymbolRequest -fmClientDocumentSymbolRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentDocumentSymbol params - --- * :leftwards_arrow_with_hook: [textDocument/formatting](#textDocument_formatting) -fmClientDocumentFormattingRequest :: J.LspId -> J.DocumentFormattingParams -> J.DocumentFormattingRequest -fmClientDocumentFormattingRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentFormatting params - --- * :leftwards_arrow_with_hook: [textDocument/rangeFormatting](#textDocument_rangeFormatting) -fmClientDocumentRangeFormattingRequest :: J.LspId -> J.DocumentRangeFormattingParams -> J.DocumentRangeFormattingRequest -fmClientDocumentRangeFormattingRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentRangeFormatting params - --- * :leftwards_arrow_with_hook: [textDocument/onTypeFormatting](#textDocument_onTypeFormatting) -fmClientDocumentOnTypeFormattingRequest :: J.LspId -> J.DocumentOnTypeFormattingParams -> J.DocumentOnTypeFormattingRequest -fmClientDocumentOnTypeFormattingRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentOnTypeFormatting params - --- * :leftwards_arrow_with_hook: [textDocument/definition](#textDocument_definition) -fmClientDefinitionRequest :: J.LspId -> J.TextDocumentPositionParams -> J.DefinitionRequest -fmClientDefinitionRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentDefinition params - --- * :leftwards_arrow_with_hook: [textDocument/codeAction](#textDocument_codeAction) -fmClientCodeActionRequest :: J.LspId -> J.CodeActionParams -> J.CodeActionRequest -fmClientCodeActionRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentCodeAction params - --- * :leftwards_arrow_with_hook: [textDocument/codeLens](#textDocument_codeLens) -fmClientCodeLensRequest :: J.LspId -> J.CodeLensParams -> J.CodeLensRequest -fmClientCodeLensRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentCodeLens params - --- * :leftwards_arrow_with_hook: [codeLens/resolve](#codeLens_resolve) -fmClientCodeLensResolveRequest :: J.LspId -> J.CodeLens -> J.CodeLensResolveRequest -fmClientCodeLensResolveRequest rid params - = J.RequestMessage "2.0" rid J.CodeLensResolve params - --- * :leftwards_arrow_with_hook: [textDocument/documentLink](#textDocument_documentLink) -fmClientDocumentLinkRequest :: J.LspId -> J.DocumentLinkParams -> J.DocumentLinkRequest -fmClientDocumentLinkRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentDocumentLink params - --- * :leftwards_arrow_with_hook: [documentLink/resolve](#documentLink_resolve) -fmClientDocumentLinkResolveRequest :: J.LspId -> J.DocumentLink -> J.DocumentLinkResolveRequest -fmClientDocumentLinkResolveRequest rid params - = J.RequestMessage "2.0" rid J.DocumentLinkResolve params - --- * :leftwards_arrow_with_hook: [textDocument/rename](#textDocument_rename) -fmClientRenameRequest :: J.LspId -> J.RenameParams -> J.RenameRequest -fmClientRenameRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentRename params - --- * :leftwards_arrow_with_hook: [textDocument/prepareRename](#textDocument_prepareRename) -fmClientPrepareRenameRequest :: J.LspId -> J.TextDocumentPositionParams -> J.PrepareRenameRequest -fmClientPrepareRenameRequest rid params - = J.RequestMessage "2.0" rid J.TextDocumentPrepareRename params diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs new file mode 100644 index 000000000..83c4067fa --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +module Language.Haskell.LSP.Types.Method where + +import qualified Data.Aeson as A +import Data.Aeson.Types +import Data.Text (Text) +import Language.Haskell.LSP.Types.Utils +import Data.Function (on) +import Control.Applicative + +-- --------------------------------------------------------------------- + +data Provenance = FromServer | FromClient +data MethodType = Notification | Request + +data Method (p :: Provenance) (t :: MethodType) where +-- Client Methods + -- General + Initialize :: Method FromClient Request + Initialized :: Method FromClient Notification + Shutdown :: Method FromClient Request + Exit :: Method FromClient Notification + -- Workspace + WorkspaceDidChangeWorkspaceFolders :: Method FromClient Notification + WorkspaceDidChangeConfiguration :: Method FromClient Notification + WorkspaceDidChangeWatchedFiles :: Method FromClient Notification + WorkspaceSymbol :: Method FromClient Request + WorkspaceExecuteCommand :: Method FromClient Request + -- Progress + WorkDoneProgressCancel :: Method FromClient Notification + -- Document + TextDocumentDidOpen :: Method FromClient Notification + TextDocumentDidChange :: Method FromClient Notification + TextDocumentWillSave :: Method FromClient Notification + TextDocumentWillSaveWaitUntil :: Method FromClient Request + TextDocumentDidSave :: Method FromClient Notification + TextDocumentDidClose :: Method FromClient Notification + -- Completion + TextDocumentCompletion :: Method FromClient Request + CompletionItemResolve :: Method FromClient Request + -- LanguageQueries + TextDocumentHover :: Method FromClient Request + TextDocumentSignatureHelp :: Method FromClient Request + TextDocumentDefinition :: Method FromClient Request + TextDocumentTypeDefinition :: Method FromClient Request + TextDocumentImplementation :: Method FromClient Request + TextDocumentReferences :: Method FromClient Request + TextDocumentDocumentHighlight :: Method FromClient Request + TextDocumentDocumentSymbol :: Method FromClient Request + -- Code Action/Lens/Link + TextDocumentCodeAction :: Method FromClient Request + TextDocumentCodeLens :: Method FromClient Request + CodeLensResolve :: Method FromClient Request + TextDocumentDocumentLink :: Method FromClient Request + DocumentLinkResolve :: Method FromClient Request + -- Syntax highlighting/Coloring + TextDocumentDocumentColor :: Method FromClient Request + TextDocumentColorPresentation :: Method FromClient Request + -- Formatting + TextDocumentFormatting :: Method FromClient Request + TextDocumentRangeFormatting :: Method FromClient Request + TextDocumentOnTypeFormatting :: Method FromClient Request + -- Rename + TextDocumentRename :: Method FromClient Request + TextDocumentPrepareRename :: Method FromClient Request + -- FoldingRange + TextDocumentFoldingRange :: Method FromClient Request + +-- ServerMethods + -- Window + WindowShowMessage :: Method FromServer Notification + WindowShowMessageRequest :: Method FromServer Request + WindowLogMessage :: Method FromServer Notification + WindowWorkDoneProgressCreate :: Method FromServer Request + Progress :: Method FromServer Notification + TelemetryEvent :: Method FromServer Notification + -- Capability + ClientRegisterCapability :: Method FromServer Request + ClientUnregisterCapability :: Method FromServer Request + -- Workspace + WorkspaceWorkspaceFolders :: Method FromServer Request + WorkspaceConfiguration :: Method FromServer Request + WorkspaceApplyEdit :: Method FromServer Request + -- Document + TextDocumentPublishDiagnostics :: Method FromServer Notification + +-- Cancelling + CancelRequest :: Method p Notification + +-- Custom + -- A custom message type. It is not enforced that this starts with $/. + CustomMethod :: Method p t + +data SMethod (m :: Method p t) where + SInitialize :: SMethod Initialize + SInitialized :: SMethod Initialized + SShutdown :: SMethod Shutdown + SExit :: SMethod Exit + SWorkspaceDidChangeWorkspaceFolders :: SMethod WorkspaceDidChangeWorkspaceFolders + SWorkspaceDidChangeConfiguration :: SMethod WorkspaceDidChangeConfiguration + SWorkspaceDidChangeWatchedFiles :: SMethod WorkspaceDidChangeWatchedFiles + SWorkspaceSymbol :: SMethod WorkspaceSymbol + SWorkspaceExecuteCommand :: SMethod WorkspaceExecuteCommand + SWorkDoneProgressCancel :: SMethod WorkDoneProgressCancel + STextDocumentDidOpen :: SMethod TextDocumentDidOpen + STextDocumentDidChange :: SMethod TextDocumentDidChange + STextDocumentWillSave :: SMethod TextDocumentWillSave + STextDocumentWillSaveWaitUntil :: SMethod TextDocumentWillSaveWaitUntil + STextDocumentDidSave :: SMethod TextDocumentDidSave + STextDocumentDidClose :: SMethod TextDocumentDidClose + STextDocumentCompletion :: SMethod TextDocumentCompletion + SCompletionItemResolve :: SMethod CompletionItemResolve + STextDocumentHover :: SMethod TextDocumentHover + STextDocumentSignatureHelp :: SMethod TextDocumentSignatureHelp + STextDocumentDefinition :: SMethod TextDocumentDefinition + STextDocumentTypeDefinition :: SMethod TextDocumentTypeDefinition + STextDocumentImplementation :: SMethod TextDocumentImplementation + STextDocumentReferences :: SMethod TextDocumentReferences + STextDocumentDocumentHighlight :: SMethod TextDocumentDocumentHighlight + STextDocumentDocumentSymbol :: SMethod TextDocumentDocumentSymbol + STextDocumentCodeAction :: SMethod TextDocumentCodeAction + STextDocumentCodeLens :: SMethod TextDocumentCodeLens + SCodeLensResolve :: SMethod CodeLensResolve + STextDocumentDocumentLink :: SMethod TextDocumentDocumentLink + SDocumentLinkResolve :: SMethod DocumentLinkResolve + STextDocumentDocumentColor :: SMethod TextDocumentDocumentColor + STextDocumentColorPresentation :: SMethod TextDocumentColorPresentation + STextDocumentFormatting :: SMethod TextDocumentFormatting + STextDocumentRangeFormatting :: SMethod TextDocumentRangeFormatting + STextDocumentOnTypeFormatting :: SMethod TextDocumentOnTypeFormatting + STextDocumentRename :: SMethod TextDocumentRename + STextDocumentPrepareRename :: SMethod TextDocumentPrepareRename + STextDocumentFoldingRange :: SMethod TextDocumentFoldingRange + + SWindowShowMessage :: SMethod WindowShowMessage + SWindowShowMessageRequest :: SMethod WindowShowMessageRequest + SWindowLogMessage :: SMethod WindowLogMessage + SWindowWorkDoneProgressCreate :: SMethod WindowWorkDoneProgressCreate + SProgress :: SMethod Progress + STelemetryEvent :: SMethod TelemetryEvent + SClientRegisterCapability :: SMethod ClientRegisterCapability + SClientUnregisterCapability :: SMethod ClientUnregisterCapability + SWorkspaceWorkspaceFolders :: SMethod WorkspaceWorkspaceFolders + SWorkspaceConfiguration :: SMethod WorkspaceConfiguration + SWorkspaceApplyEdit :: SMethod WorkspaceApplyEdit + STextDocumentPublishDiagnostics :: SMethod TextDocumentPublishDiagnostics + + SCancelRequest :: SMethod CancelRequest + SCustomMethod :: Text -> SMethod CustomMethod + +deriving instance Eq (SMethod m) +deriving instance Ord (SMethod m) +deriving instance Show (SMethod m) + +data SomeClientMethod = forall t (m :: Method FromClient t). SomeClientMethod (SMethod m) +data SomeServerMethod = forall t (m :: Method FromServer t). SomeServerMethod (SMethod m) + +data SomeMethod where + SomeMethod :: forall m. SMethod m -> SomeMethod + +deriving instance Show SomeMethod +instance Eq SomeMethod where + (==) = (==) `on` toJSON +instance Ord SomeMethod where + compare = compare `on` (getString . toJSON) + where + getString (A.String t) = t + getString _ = error "ToJSON instance for some method isn't string" +deriving instance Show SomeClientMethod +instance Eq SomeClientMethod where + (==) = (==) `on` toJSON +instance Ord SomeClientMethod where + compare = compare `on` (getString . toJSON) + where + getString (A.String t) = t + getString _ = error "ToJSON instance for some method isn't string" +deriving instance Show SomeServerMethod +instance Eq SomeServerMethod where + (==) = (==) `on` toJSON +instance Ord SomeServerMethod where + compare = compare `on` (getString . toJSON) + where + getString (A.String t) = t + getString _ = error "ToJSON instance for some method isn't string" + +-- --------------------------------------------------------------------- +-- From JSON +-- --------------------------------------------------------------------- + +instance FromJSON SomeMethod where + parseJSON v = client <|> server + where + client = do + c <- parseJSON v + case c of + -- Don't parse the client custom method so that we can still + -- parse the server methods + SomeClientMethod (SCustomMethod _) -> mempty + SomeClientMethod m -> pure $ SomeMethod m + server = do + c <- parseJSON v + case c of + SomeServerMethod m -> pure $ SomeMethod m + +instance FromJSON SomeClientMethod where + -- General + parseJSON (A.String "initialize") = pure $ SomeClientMethod SInitialize + parseJSON (A.String "initialized") = pure $ SomeClientMethod SInitialized + parseJSON (A.String "shutdown") = pure $ SomeClientMethod SShutdown + parseJSON (A.String "exit") = pure $ SomeClientMethod SExit + -- Workspace + parseJSON (A.String "workspace/didChangeWorkspaceFolders") = pure $ SomeClientMethod SWorkspaceDidChangeWorkspaceFolders + parseJSON (A.String "workspace/didChangeConfiguration") = pure $ SomeClientMethod SWorkspaceDidChangeConfiguration + parseJSON (A.String "workspace/didChangeWatchedFiles") = pure $ SomeClientMethod SWorkspaceDidChangeWatchedFiles + parseJSON (A.String "workspace/symbol") = pure $ SomeClientMethod SWorkspaceSymbol + parseJSON (A.String "workspace/executeCommand") = pure $ SomeClientMethod SWorkspaceExecuteCommand + -- Document + parseJSON (A.String "textDocument/didOpen") = pure $ SomeClientMethod STextDocumentDidOpen + parseJSON (A.String "textDocument/didChange") = pure $ SomeClientMethod STextDocumentDidChange + parseJSON (A.String "textDocument/willSave") = pure $ SomeClientMethod STextDocumentWillSave + parseJSON (A.String "textDocument/willSaveWaitUntil") = pure $ SomeClientMethod STextDocumentWillSaveWaitUntil + parseJSON (A.String "textDocument/didSave") = pure $ SomeClientMethod STextDocumentDidSave + parseJSON (A.String "textDocument/didClose") = pure $ SomeClientMethod STextDocumentDidClose + parseJSON (A.String "textDocument/completion") = pure $ SomeClientMethod STextDocumentCompletion + parseJSON (A.String "completionItem/resolve") = pure $ SomeClientMethod SCompletionItemResolve + parseJSON (A.String "textDocument/hover") = pure $ SomeClientMethod STextDocumentHover + parseJSON (A.String "textDocument/signatureHelp") = pure $ SomeClientMethod STextDocumentSignatureHelp + parseJSON (A.String "textDocument/definition") = pure $ SomeClientMethod STextDocumentDefinition + parseJSON (A.String "textDocument/typeDefinition") = pure $ SomeClientMethod STextDocumentTypeDefinition + parseJSON (A.String "textDocument/implementation") = pure $ SomeClientMethod STextDocumentImplementation + parseJSON (A.String "textDocument/references") = pure $ SomeClientMethod STextDocumentReferences + parseJSON (A.String "textDocument/documentHighlight") = pure $ SomeClientMethod STextDocumentDocumentHighlight + parseJSON (A.String "textDocument/documentSymbol") = pure $ SomeClientMethod STextDocumentDocumentSymbol + parseJSON (A.String "textDocument/codeAction") = pure $ SomeClientMethod STextDocumentCodeAction + parseJSON (A.String "textDocument/codeLens") = pure $ SomeClientMethod STextDocumentCodeLens + parseJSON (A.String "codeLens/resolve") = pure $ SomeClientMethod SCodeLensResolve + parseJSON (A.String "textDocument/documentLink") = pure $ SomeClientMethod STextDocumentDocumentLink + parseJSON (A.String "documentLink/resolve") = pure $ SomeClientMethod SDocumentLinkResolve + parseJSON (A.String "textDocument/documentColor") = pure $ SomeClientMethod STextDocumentDocumentColor + parseJSON (A.String "textDocument/colorPresentation") = pure $ SomeClientMethod STextDocumentColorPresentation + parseJSON (A.String "textDocument/formatting") = pure $ SomeClientMethod STextDocumentFormatting + parseJSON (A.String "textDocument/rangeFormatting") = pure $ SomeClientMethod STextDocumentRangeFormatting + parseJSON (A.String "textDocument/onTypeFormatting") = pure $ SomeClientMethod STextDocumentOnTypeFormatting + parseJSON (A.String "textDocument/rename") = pure $ SomeClientMethod STextDocumentRename + parseJSON (A.String "textDocument/prepareRename") = pure $ SomeClientMethod STextDocumentPrepareRename + parseJSON (A.String "textDocument/foldingRange") = pure $ SomeClientMethod STextDocumentFoldingRange + parseJSON (A.String "window/workDoneProgress/cancel") = pure $ SomeClientMethod SWorkDoneProgressCancel +-- Cancelling + parseJSON (A.String "$/cancelRequest") = pure $ SomeClientMethod SCancelRequest +-- Custom + parseJSON (A.String m) = pure $ SomeClientMethod (SCustomMethod m) + parseJSON _ = mempty + +instance A.FromJSON SomeServerMethod where +-- Server + -- Window + parseJSON (A.String "window/showMessage") = pure $ SomeServerMethod SWindowShowMessage + parseJSON (A.String "window/showMessageRequest") = pure $ SomeServerMethod SWindowShowMessageRequest + parseJSON (A.String "window/logMessage") = pure $ SomeServerMethod SWindowLogMessage + parseJSON (A.String "window/workDoneProgress/create") = pure $ SomeServerMethod SWindowWorkDoneProgressCreate + parseJSON (A.String "$/progress") = pure $ SomeServerMethod SProgress + parseJSON (A.String "telemetry/event") = pure $ SomeServerMethod STelemetryEvent + -- Client + parseJSON (A.String "client/registerCapability") = pure $ SomeServerMethod SClientRegisterCapability + parseJSON (A.String "client/unregisterCapability") = pure $ SomeServerMethod SClientUnregisterCapability + -- Workspace + parseJSON (A.String "workspace/workspaceFolders") = pure $ SomeServerMethod SWorkspaceWorkspaceFolders + parseJSON (A.String "workspace/configuration") = pure $ SomeServerMethod SWorkspaceConfiguration + parseJSON (A.String "workspace/applyEdit") = pure $ SomeServerMethod SWorkspaceApplyEdit + -- Document + parseJSON (A.String "textDocument/publishDiagnostics") = pure $ SomeServerMethod STextDocumentPublishDiagnostics + +-- Cancelling + parseJSON (A.String "$/cancelRequest") = pure $ SomeServerMethod SCancelRequest + +-- Custom + parseJSON (A.String m) = pure $ SomeServerMethod (SCustomMethod m) + parseJSON _ = mempty + +-- instance FromJSON (SMethod m) +makeSingletonFromJSON 'SomeMethod ''SMethod + +-- --------------------------------------------------------------------- +-- TO JSON +-- --------------------------------------------------------------------- + +instance ToJSON SomeMethod where + toJSON (SomeMethod m) = toJSON m + +instance ToJSON SomeClientMethod where + toJSON (SomeClientMethod m) = toJSON m +instance ToJSON SomeServerMethod where + toJSON (SomeServerMethod m) = toJSON m + +instance A.ToJSON (SMethod m) where +-- Client + -- General + toJSON SInitialize = A.String "initialize" + toJSON SInitialized = A.String "initialized" + toJSON SShutdown = A.String "shutdown" + toJSON SExit = A.String "exit" + -- Workspace + toJSON SWorkspaceDidChangeWorkspaceFolders = A.String "workspace/didChangeWorkspaceFolders" + toJSON SWorkspaceDidChangeConfiguration = A.String "workspace/didChangeConfiguration" + toJSON SWorkspaceDidChangeWatchedFiles = A.String "workspace/didChangeWatchedFiles" + toJSON SWorkspaceSymbol = A.String "workspace/symbol" + toJSON SWorkspaceExecuteCommand = A.String "workspace/executeCommand" + -- Document + toJSON STextDocumentDidOpen = A.String "textDocument/didOpen" + toJSON STextDocumentDidChange = A.String "textDocument/didChange" + toJSON STextDocumentWillSave = A.String "textDocument/willSave" + toJSON STextDocumentWillSaveWaitUntil = A.String "textDocument/willSaveWaitUntil" + toJSON STextDocumentDidSave = A.String "textDocument/didSave" + toJSON STextDocumentDidClose = A.String "textDocument/didClose" + toJSON STextDocumentCompletion = A.String "textDocument/completion" + toJSON SCompletionItemResolve = A.String "completionItem/resolve" + toJSON STextDocumentHover = A.String "textDocument/hover" + toJSON STextDocumentSignatureHelp = A.String "textDocument/signatureHelp" + toJSON STextDocumentReferences = A.String "textDocument/references" + toJSON STextDocumentDocumentHighlight = A.String "textDocument/documentHighlight" + toJSON STextDocumentDocumentSymbol = A.String "textDocument/documentSymbol" + toJSON STextDocumentDefinition = A.String "textDocument/definition" + toJSON STextDocumentTypeDefinition = A.String "textDocument/typeDefinition" + toJSON STextDocumentImplementation = A.String "textDocument/implementation" + toJSON STextDocumentCodeAction = A.String "textDocument/codeAction" + toJSON STextDocumentCodeLens = A.String "textDocument/codeLens" + toJSON SCodeLensResolve = A.String "codeLens/resolve" + toJSON STextDocumentDocumentColor = A.String "textDocument/documentColor" + toJSON STextDocumentColorPresentation = A.String "textDocument/colorPresentation" + toJSON STextDocumentFormatting = A.String "textDocument/formatting" + toJSON STextDocumentRangeFormatting = A.String "textDocument/rangeFormatting" + toJSON STextDocumentOnTypeFormatting = A.String "textDocument/onTypeFormatting" + toJSON STextDocumentRename = A.String "textDocument/rename" + toJSON STextDocumentPrepareRename = A.String "textDocument/prepareRename" + toJSON STextDocumentFoldingRange = A.String "textDocument/foldingRange" + toJSON STextDocumentDocumentLink = A.String "textDocument/documentLink" + toJSON SDocumentLinkResolve = A.String "documentLink/resolve" + toJSON SWorkDoneProgressCancel = A.String "window/workDoneProgress/cancel" +-- Server + -- Window + toJSON SWindowShowMessage = A.String "window/showMessage" + toJSON SWindowShowMessageRequest = A.String "window/showMessageRequest" + toJSON SWindowLogMessage = A.String "window/logMessage" + toJSON SWindowWorkDoneProgressCreate = A.String "window/workDoneProgress/create" + toJSON SProgress = A.String "$/progress" + toJSON STelemetryEvent = A.String "telemetry/event" + -- Client + toJSON SClientRegisterCapability = A.String "client/registerCapability" + toJSON SClientUnregisterCapability = A.String "client/unregisterCapability" + -- Workspace + toJSON SWorkspaceWorkspaceFolders = A.String "workspace/workspaceFolders" + toJSON SWorkspaceConfiguration = A.String "workspace/configuration" + toJSON SWorkspaceApplyEdit = A.String "workspace/applyEdit" + -- Document + toJSON STextDocumentPublishDiagnostics = A.String "textDocument/publishDiagnostics" + -- Cancelling + toJSON SCancelRequest = A.String "$/cancelRequest" +-- Custom + toJSON (SCustomMethod m) = A.String m diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs index feb74bd84..8dbb72dc5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs @@ -11,7 +11,6 @@ import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location -import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress -- --------------------------------------------------------------------- @@ -269,5 +268,3 @@ instance ToJSON DSResult where toJSON (DSSymbolInformation x) = toJSON x -type DocumentSymbolRequest = RequestMessage ClientMethod DocumentSymbolParams DSResult -type DocumentSymbolsResponse = ResponseMessage DSResult diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs new file mode 100644 index 000000000..89f67661c --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + +module Language.Haskell.LSP.Types.Synonyms where + +import Language.Haskell.LSP.Types.Method +import Language.Haskell.LSP.Types.Message + +-- Server Messages + +-- Window +type ShowMessageNotification = Message WindowShowMessage + +type ShowMessageRequest = Message WindowShowMessageRequest +type ShowMessageResponse = ResponseMessage WindowShowMessageRequest + +type LogMessageNotification = Message WindowLogMessage + +type WindowWorkDoneProgressCreateRequest = Message WindowWorkDoneProgressCreate +type WindowWorkDoneProgressCreateResponse = ResponseMessage WindowWorkDoneProgressCreate + +type ProgressNotification = Message Progress + +type TelemetryNotification = Message TelemetryEvent + +-- Capability +type RegisterCapabilityRequest = Message ClientRegisterCapability +type RegisterCapabilityResponse = ResponseMessage ClientRegisterCapability + +type UnregisterCapabilityRequest = Message ClientUnregisterCapability +type UnregisterCapabilityResponse = ResponseMessage ClientUnregisterCapability + +-- Workspace +type WorkspaceFoldersRequest = Message WorkspaceWorkspaceFolders +type WorkspaceFoldersResponse = ResponseMessage WorkspaceWorkspaceFolders + +type ConfigurationRequest = Message WorkspaceConfiguration +type ConfigurationResponse = ResponseMessage WorkspaceConfiguration + +type ApplyWorkspaceEditRequest = Message WorkspaceApplyEdit +type ApplyWorkspaceEditResponse = ResponseMessage WorkspaceApplyEdit + +-- Document/Diagnostic +type PublishDiagnosticsNotification = Message TextDocumentPublishDiagnostics + +-- Cancel +type CancelNotificationServer = Message CancelRequest + +-- Custom +type CustomServerNotification = Message CustomMethod +type CustomServerRequest = Message CustomMethod + +-- Client Messages + +-- General +type InitializeRequest = Message Initialize +type InitializeResponse = ResponseMessage Initialize + +type InitializedNotification = Message Initialized + +type ShutdownRequest = Message Shutdown +type ShutdownResponse = ResponseMessage Shutdown + +type ExitNotification = Message Exit +type CancelNotification = Message CancelRequest + +-- Workspace +type DidChangeWorkspaceFoldersNotification = Message WorkspaceDidChangeWorkspaceFolders +type DidChangeConfigurationNotification = Message WorkspaceDidChangeConfiguration +type DidChangeWatchedFilesNotification = Message WorkspaceDidChangeWatchedFiles + +type WorkspaceSymbolRequest = Message WorkspaceSymbol +type WorkspaceSymbolsResponse = ResponseMessage WorkspaceSymbol + +type ExecuteCommandRequest = Message WorkspaceExecuteCommand +type ExecuteCommandResponse = ResponseMessage WorkspaceExecuteCommand + +type WorkDoneProgressCancelNotification = Message WorkDoneProgressCancel + +-- Document/Sync +type DidOpenTextDocumentNotification = Message TextDocumentDidOpen +type DidChangeTextDocumentNotification = Message TextDocumentDidChange +type WillSaveTextDocumentNotification = Message TextDocumentWillSave + +type WillSaveWaitUntilTextDocumentRequest = Message TextDocumentWillSaveWaitUntil +type WillSaveWaitUntilTextDocumentResponse = ResponseMessage TextDocumentWillSaveWaitUntil + +type DidSaveTextDocumentNotification = Message TextDocumentDidSave +type DidCloseTextDocumentNotification = Message TextDocumentDidClose + +-- Completion + +type CompletionRequest = Message TextDocumentCompletion +type CompletionResponse = ResponseMessage TextDocumentCompletion + +type CompletionItemResolveRequest = Message CompletionItemResolve +type CompletionItemResolveResponse = ResponseMessage CompletionItemResolve + +-- Queries +type HoverRequest = Message TextDocumentHover +type HoverResponse = ResponseMessage TextDocumentHover + +type SignatureHelpRequest = Message TextDocumentSignatureHelp +type SignatureHelpResponse = ResponseMessage TextDocumentSignatureHelp + +type DefinitionRequest = Message TextDocumentDefinition +type DefinitionResponse = ResponseMessage TextDocumentDefinition + +type TypeDefinitionRequest = Message TextDocumentTypeDefinition +type TypeDefinitionResponse = ResponseMessage TextDocumentTypeDefinition + +type ImplementationRequest = Message TextDocumentImplementation +type ImplementationResponse = ResponseMessage TextDocumentImplementation + +type ReferencesRequest = Message TextDocumentReferences +type ReferencesResponse = ResponseMessage TextDocumentReferences + +type DocumentHighlightRequest = Message TextDocumentDocumentHighlight +type DocumentHighlightsResponse = ResponseMessage TextDocumentDocumentHighlight + +type DocumentSymbolRequest = Message TextDocumentDocumentSymbol +type DocumentSymbolsResponse = ResponseMessage TextDocumentDocumentSymbol + +-- Code Lens/Action/Link + +type CodeActionRequest = Message TextDocumentCodeAction +type CodeActionResponse = ResponseMessage TextDocumentCodeAction + +type CodeLensRequest = Message TextDocumentCodeLens +type CodeLensResponse = ResponseMessage TextDocumentCodeLens + +type CodeLensResolveRequest = Message CodeLensResolve +type CodeLensResolveResponse = ResponseMessage CodeLensResolve + +type DocumentLinkRequest = Message TextDocumentDocumentLink +type DocumentLinkResponse = ResponseMessage TextDocumentDocumentLink + +type DocumentLinkResolveRequest = Message DocumentLinkResolve +type DocumentLinkResolveResponse = ResponseMessage DocumentLinkResolve + +-- Color/Syntax + +type DocumentColorRequest = Message TextDocumentDocumentColor +type DocumentColorResponse = ResponseMessage TextDocumentDocumentColor + +type ColorPresentationRequest = Message TextDocumentColorPresentation +type ColorPresentationResponse = ResponseMessage TextDocumentColorPresentation + + +-- Formatting +type DocumentFormattingRequest = Message TextDocumentFormatting +type DocumentFormattingResponse = ResponseMessage TextDocumentFormatting + +type DocumentRangeFormattingRequest = Message TextDocumentRangeFormatting +type DocumentRangeFormattingResponse = ResponseMessage TextDocumentRangeFormatting + +type DocumentOnTypeFormattingRequest = Message TextDocumentOnTypeFormatting +type DocumentOnTypeFormattingResponse = ResponseMessage TextDocumentOnTypeFormatting + +-- Rename +type RenameRequest = Message TextDocumentRename +type RenameResponse = ResponseMessage TextDocumentRename + +type PrepareRenameRequest = Message TextDocumentPrepareRename +type PrepareRenameResponse = ResponseMessage TextDocumentPrepareRename + +-- Folding +type FoldingRangeRequest = Message TextDocumentFoldingRange +type FoldingRangeResponse = ResponseMessage TextDocumentFoldingRange + +-- Custom +type CustomClientNotification = Message CustomMethod +type CustomClientRequest = Message CustomMethod +type CustomResponse = ResponseMessage CustomMethod diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs index d2d55b3a4..b6843a826 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs @@ -113,8 +113,8 @@ platformAdjustFromUriPath systemOS authority srcPath = if systemOS /= windowsOS || null srcPath then srcPath else let firstSegment:rest = (FPP.splitDirectories . tail) srcPath -- Drop leading '/' for absolute Windows paths - drive = if FPW.isDrive firstSegment - then FPW.addTrailingPathSeparator firstSegment + drive = if FPW.isDrive firstSegment + then FPW.addTrailingPathSeparator firstSegment else firstSegment in FPW.joinDrive drive $ FPW.joinPath rest diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs index 8b7b23110..7a70bdb44 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs @@ -1,6 +1,43 @@ -module Language.Haskell.LSP.Types.Utils where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.LSP.Types.Utils + ( rdrop + , makeSingletonFromJSON + ) where + +import Language.Haskell.TH +import Data.Aeson +import Control.Monad +import Data.List (foldl') -- --------------------------------------------------------------------- rdrop :: Int -> [a] -> [a] rdrop cnt = reverse . drop cnt . reverse + +-- | Given a wrapper and a singleton GADT, construct FromJSON +-- instances for each constructor return type by invoking the +-- FromJSON instance for the wrapper and unwrapping +makeSingletonFromJSON :: Name -> Name -> Q [Dec] +makeSingletonFromJSON wrap gadt = do + TyConI (DataD _ _ _ _ cons _) <- reify gadt + concat <$> mapM (makeInst wrap) cons + +{- +instance FromJSON (SMethod $method) where + parseJSON = parseJSON >=> \case + SomeMethod $singleton-method -> pure $singleton-method + _ -> mempty +-} +makeInst :: Name -> Con -> Q [Dec] +makeInst wrap (GadtC [sConstructor] args t) = do + ns <- replicateM (length args) (newName "x") + let wrappedPat = pure $ ConP wrap [ConP sConstructor (map VarP ns)] + unwrappedE = pure $ foldl' AppE (ConE sConstructor) (map VarE ns) + [d| instance FromJSON $(pure t) where + parseJSON = parseJSON >=> \case + $wrappedPat -> pure $unwrappedE + _ -> mempty + |] +makeInst wrap (ForallC _ _ con) = makeInst wrap con -- Cancel and Custom requests +makeInst _ _ = fail "makeInst only defined for GADT constructors" diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs index a99ad145a..1186f3a1f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs @@ -2,15 +2,16 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFunctor #-} module Language.Haskell.LSP.Types.Window where +import Control.Applicative import Control.Monad (unless) import qualified Data.Aeson as A import Data.Aeson.TH import Data.Maybe (catMaybes) import Data.Text (Text) import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress -- --------------------------------------------------------------------- @@ -90,8 +91,6 @@ data ShowMessageParams = deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageParams -type ShowMessageNotification = NotificationMessage ServerMethod ShowMessageParams - -- --------------------------------------------------------------------- {- ShowMessage Request @@ -157,9 +156,6 @@ data ShowMessageRequestParams = deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageRequestParams -type ShowMessageRequest = RequestMessage ServerMethod ShowMessageRequestParams Text -type ShowMessageResponse = ResponseMessage Text - -- --------------------------------------------------------------------- {- LogMessage Notification @@ -197,9 +193,6 @@ data LogMessageParams = deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''LogMessageParams - -type LogMessageNotification = NotificationMessage ServerMethod LogMessageParams - {- Progress Begin Notification @@ -249,10 +242,27 @@ data ProgressParams t = ProgressParams { _token :: ProgressToken , _value :: t - } deriving (Show, Read, Eq) + } deriving (Show, Read, Eq, Functor) deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ProgressParams +data SomeProgressParams + = Begin WorkDoneProgressBeginParams + | Report WorkDoneProgressReportParams + | End WorkDoneProgressEndParams + deriving Eq + +instance A.FromJSON SomeProgressParams where + parseJSON x = + (Begin <$> A.parseJSON x) + <|> (Report <$> A.parseJSON x) + <|> (End <$> A.parseJSON x) + +instance A.ToJSON SomeProgressParams where + toJSON (Begin x) = A.toJSON x + toJSON (Report x) = A.toJSON x + toJSON (End x) = A.toJSON x + -- | Parameters for 'WorkDoneProgressBeginNotification'. -- -- @since 0.10.0.0 @@ -306,8 +316,6 @@ instance A.FromJSON WorkDoneProgressBeginParams where -- client to ask the client to start progress. -- -- @since 0.10.0.0 -type WorkDoneProgressBeginNotification = NotificationMessage ServerMethod (ProgressParams WorkDoneProgressBeginParams) - {- Progress Report Notification @@ -389,8 +397,6 @@ instance A.FromJSON WorkDoneProgressReportParams where -- client to report progress for a previously started progress. -- -- @since 0.10.0.0 -type WorkDoneProgressReportNotification = NotificationMessage ServerMethod (ProgressParams WorkDoneProgressReportParams) - {- Progress End Notification @@ -434,8 +440,6 @@ instance A.FromJSON WorkDoneProgressEndParams where -- client to stop a previously started progress. -- -- @since 0.10.0.0 -type WorkDoneProgressEndNotification = NotificationMessage ServerMethod (ProgressParams WorkDoneProgressEndParams) - {- Progress Cancel Notification @@ -470,13 +474,11 @@ deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressC -- A server receiving a cancel request must still close a progress using the done notification. -- -- @since 0.10.0.0 -type WorkDoneProgressCancelNotification = NotificationMessage ClientMethod WorkDoneProgressCancelParams data WorkDoneProgressCreateParams = - WorkDoneProgressCreateParams { + WorkDoneProgressCreateParams { _token :: ProgressToken } deriving (Show, Read, Eq) deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressCreateParams -type WorkDoneProgressCreateRequest = RequestMessage ServerMethod WorkDoneProgressCreateParams () diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs index 41bbd9188..bbcc141a7 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs @@ -6,7 +6,6 @@ import Data.Aeson.TH import Data.Text ( Text ) import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.List -import Language.Haskell.LSP.Types.Message {- Workspace folders request (:arrow_right_hook:) @@ -58,10 +57,6 @@ data WorkspaceFolder = } deriving (Read, Show, Eq) deriveJSON lspOptions ''WorkspaceFolder - -type WorkspaceFoldersRequest = RequestMessage ServerMethod () (Maybe (List WorkspaceFolder)) -type WorkspaceFoldersResponse = ResponseMessage (Maybe (List WorkspaceFolder)) - {- DidChangeWorkspaceFolders Notification (:arrow_right:) Since version 3.6.0 @@ -125,5 +120,3 @@ data DidChangeWorkspaceFoldersParams = deriveJSON lspOptions ''DidChangeWorkspaceFoldersParams -type DidChangeWorkspaceFoldersNotification = - NotificationMessage ClientMethod DidChangeWorkspaceFoldersParams diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 7c7d1f235..6377fe8e2 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -24,12 +24,10 @@ library reexported-modules: Language.Haskell.LSP.Types , Language.Haskell.LSP.Types.Capabilities , Language.Haskell.LSP.Types.Lens - exposed-modules: Language.Haskell.LSP.Capture - , Language.Haskell.LSP.Constant + exposed-modules: Language.Haskell.LSP.Constant , Language.Haskell.LSP.Core , Language.Haskell.LSP.Control , Language.Haskell.LSP.Diagnostics - , Language.Haskell.LSP.Messages , Language.Haskell.LSP.Utility , Language.Haskell.LSP.VFS -- other-modules: @@ -53,17 +51,19 @@ library , rope-utf16-splay >= 0.3.1.0 , sorted-list == 0.2.1.* , stm + , scientific , temporary , text + , transformers , time , unordered-containers hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-kinds executable lsp-hello main-is: Main.hs hs-source-dirs: example - -- src default-language: Haskell2010 ghc-options: -Wall @@ -78,7 +78,6 @@ executable lsp-hello , lens >= 4.15.2 , mtl , network-uri - , rope-utf16-splay >= 0.2 , stm , text , time diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 000000000..a1ccc46a8 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,10 @@ +# This is a sample hie.yaml file for opening haskell-language-server +# in hie, using cabal as the build system. To use is, copy it to a +# file called 'hie.yaml' +# WARNING: This configuration works for hie but does not for +# haskell-language-server or ghcide. +# They need support for multi-cradle: +# https://github.com/digital-asset/ghcide/issues/113 +cradle: + cabal: + component: "haskell-lsp" diff --git a/src/Language/Haskell/LSP/Capture.hs b/src/Language/Haskell/LSP/Capture.hs deleted file mode 100644 index a782cd725..000000000 --- a/src/Language/Haskell/LSP/Capture.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.LSP.Capture - ( Event(..) - , CaptureContext - , noCapture - , captureToFile - , captureFromClient - , captureFromServer - ) where - -import Data.Aeson -import Data.ByteString.Lazy.Char8 as BSL -import Data.Time.Clock -import GHC.Generics -import Language.Haskell.LSP.Messages -import System.IO -import Language.Haskell.LSP.Utility -import Control.Concurrent -import Control.Monad -import Control.Concurrent.STM - -data Event = FromClient !UTCTime !FromClientMessage - | FromServer !UTCTime !FromServerMessage - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -data CaptureContext = NoCapture | Capture (TChan Event) - -noCapture :: CaptureContext -noCapture = NoCapture - -captureToFile :: FilePath -> IO CaptureContext -captureToFile fname = do - logs $ "haskell-lsp:Logging to " ++ fname - chan <- newTChanIO - _tid <- forkIO $ withFile fname WriteMode $ writeToHandle chan - return $ Capture chan - -captureFromServer :: FromServerMessage -> CaptureContext -> IO () -captureFromServer _ NoCapture = return () -captureFromServer msg (Capture chan) = do - time <- getCurrentTime - atomically $ writeTChan chan $ FromServer time msg - -captureFromClient :: FromClientMessage -> CaptureContext -> IO () -captureFromClient _ NoCapture = return () -captureFromClient msg (Capture chan) = do - time <- getCurrentTime - atomically $ writeTChan chan $ FromClient time msg - -writeToHandle :: TChan Event -> Handle -> IO () -writeToHandle chan hdl = forever $ do - ev <- atomically $ readTChan chan - BSL.hPutStrLn hdl $ encode ev diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs index 94a953ec8..7ccda8f4f 100644 --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Language.Haskell.LSP.Control ( @@ -14,7 +12,6 @@ module Language.Haskell.LSP.Control import Control.Concurrent import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TVar import Control.Monad import Control.Monad.STM import qualified Data.Aeson as J @@ -24,18 +21,13 @@ import qualified Data.ByteString as BS import Data.ByteString.Builder.Extra (defaultChunkSize) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B -import Data.Time.Clock -import Data.Time.Format #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif -import Language.Haskell.LSP.Capture import qualified Language.Haskell.LSP.Core as Core -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Utility import System.IO -import System.FilePath -- --------------------------------------------------------------------- @@ -46,7 +38,6 @@ run :: (Show configs) => Core.InitializeCallbacks configs -- processing will start only after this returns. -> Core.Handlers -> Core.Options - -> Maybe FilePath -- ^ File to capture the session to. -> IO Int run = runWithHandles stdin stdout @@ -60,9 +51,9 @@ runWithHandles :: (Show config) => -> Core.InitializeCallbacks config -> Core.Handlers -> Core.Options - -> Maybe FilePath -> IO Int -- exit code -runWithHandles hin hout initializeCallbacks h o captureFp = do +runWithHandles hin hout initializeCallbacks h o = do + hSetBuffering hin NoBuffering hSetEncoding hin utf8 @@ -76,7 +67,7 @@ runWithHandles hin hout initializeCallbacks h o captureFp = do BSL.hPut hout out hFlush hout - runWith clientIn clientOut initializeCallbacks h o captureFp + runWith clientIn clientOut initializeCallbacks h o -- | Starts listening and sending requests and responses -- using the specified I/O. @@ -88,56 +79,75 @@ runWith :: (Show config) => -> Core.InitializeCallbacks config -> Core.Handlers -> Core.Options - -> Maybe FilePath -> IO Int -- exit code -runWith clientIn clientOut initializeCallbacks h o captureFp = do +runWith clientIn clientOut initializeCallbacks h o = do logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..." - timestamp <- formatTime defaultTimeLocale (iso8601DateFormat (Just "%H-%M-%S")) <$> getCurrentTime - let timestampCaptureFp = fmap (\f -> dropExtension f ++ timestamp ++ takeExtension f) - captureFp - captureCtx <- maybe (return noCapture) captureToFile timestampCaptureFp - - cout <- atomically newTChan :: IO (TChan FromServerMessage) - _rhpid <- forkIO $ sendServer cout clientOut captureCtx + cout <- atomically newTChan :: IO (TChan J.Value) + _rhpid <- forkIO $ sendServer cout clientOut + let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg - let sendFunc :: Core.SendFunc - sendFunc msg = atomically $ writeTChan cout msg - let lf = error "LifeCycle error, ClientCapabilities not set yet via initialize maessage" - - tvarId <- atomically $ newTVar 0 initVFS $ \vfs -> do - tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc captureCtx vfs - - ioLoop clientIn initializeCallbacks tvarDat + ioLoop clientIn initializeCallbacks vfs h o sendMsg return 1 - -- --------------------------------------------------------------------- -ioLoop :: (Show config) => IO BS.ByteString - -> Core.InitializeCallbacks config - -> TVar (Core.LanguageContextData config) - -> IO () -ioLoop clientIn dispatcherProc tvarDat = - go (parse parser "") +ioLoop + :: Show config + => IO BS.ByteString + -> Core.InitializeCallbacks config + -> VFS + -> Core.Handlers + -> Core.Options + -> (Core.FromServerMessage -> IO ()) + -> IO () +ioLoop clientIn initializeCallbacks vfs h o sendMsg = do + minitialize <- parseOne (parse parser "") + case minitialize of + Nothing -> pure () + Just (msg,remainder) -> do + case J.eitherDecode $ BSL.fromStrict msg of + Left err -> + logm $ B.pack + "\nhaskell-lsp: Got error while decoding initialize:\n" <> str2lbs err <> "\n exiting 1 ...\n" + Right initialize -> do + mInitResp <- Core.initializeRequestHandler initializeCallbacks vfs h o sendMsg initialize + case mInitResp of + Nothing -> pure () + Just env -> loop env (parse parser remainder) where - go :: Result BS.ByteString -> IO () - go (Fail _ ctxs err) = logm $ B.pack - "\nhaskell-lsp: Failed to parse message header:\n" <> B.intercalate " > " (map str2lbs ctxs) <> ": " <> - str2lbs err <> "\n exiting 1 ...\n" - go (Partial c) = do + + parseOne :: Result BS.ByteString -> IO (Maybe (BS.ByteString,BS.ByteString)) + parseOne (Fail _ ctxs err) = do + logm $ B.pack + "\nhaskell-lsp: Failed to parse message header:\n" <> B.intercalate " > " (map str2lbs ctxs) <> ": " <> + str2lbs err <> "\n exiting 1 ...\n" + pure Nothing + parseOne (Partial c) = do bs <- clientIn if BS.null bs - then logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n" - else go (c bs) - go (Done remainder msg) = do + then do + logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n" + pure Nothing + else parseOne (c bs) + parseOne (Done remainder msg) = do logm $ B.pack "---> " <> BSL.fromStrict msg - Core.handleMessage dispatcherProc tvarDat (BSL.fromStrict msg) - go (parse parser remainder) + pure $ Just (msg,remainder) + + loop env = go + where + go r = do + res <- parseOne r + case res of + Nothing -> pure () + Just (msg,remainder) -> do + Core.runReaderT (Core.handleMessage $ BSL.fromStrict msg) env + go (parse parser remainder) + parser = do _ <- string "Content-Length: " len <- decimal @@ -147,15 +157,14 @@ ioLoop clientIn dispatcherProc tvarDat = -- --------------------------------------------------------------------- -- | Simple server to make sure all output is serialised -sendServer :: TChan FromServerMessage -> (BSL.ByteString -> IO ()) -> CaptureContext -> IO () -sendServer msgChan clientOut captureCtxt = +sendServer :: TChan J.Value -> (BSL.ByteString -> IO ()) -> IO () +sendServer msgChan clientOut = do forever $ do msg <- atomically $ readTChan msgChan -- We need to make sure we only send over the content of the message, -- and no other tags/wrapper stuff - let str = J.encode $ - J.genericToJSON (J.defaultOptions { J.sumEncoding = J.UntaggedValue }) msg + let str = J.encode msg let out = BSL.concat [ str2lbs $ "Content-Length: " ++ show (BSL.length str) @@ -165,8 +174,6 @@ sendServer msgChan clientOut captureCtxt = clientOut out logm $ B.pack "<--2--" <> str - captureFromServer msg captureCtxt - -- | -- -- diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index a24cb7d98..677bfc185 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -1,59 +1,75 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Language.Haskell.LSP.Core ( handleMessage , LanguageContextData(..) + , Handler(..) , VFSData(..) - , Handler , InitializeCallbacks(..) , LspFuncs(..) , Progress(..) , ProgressCancellable(..) , ProgressCancelledException - , SendFunc - , Handlers(..) + , Handlers , Options(..) - , defaultLanguageContextData + , ClientResponseHandler(..) + , ServerResponseHandler(..) , makeResponseMessage , makeResponseError , setupLogger - , sendErrorResponseS - , sendErrorLogS - , sendErrorShowS , reverseSortEdit - , Priority(..) + , initializeRequestHandler + , LspM + , runReaderT + , LanguageContextEnv + , FromServerMessage ) where import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad +import Control.Applicative +import Data.Functor.Product import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class import Control.Lens ( (<&>), (^.), (^?), _Just ) import qualified Data.Aeson as J +import qualified Data.Aeson.Types as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B import Data.Default +import Data.IxMap import qualified Data.HashMap.Strict as HM import qualified Data.List as L import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import Data.Maybe -import Data.Monoid +import Data.Monoid hiding (Product) 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 Language.Haskell.LSP.Types.MessageFuncs import qualified Language.Haskell.LSP.Types.Capabilities as C -import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Lens as J +import Language.Haskell.LSP.Types as J hiding (Progress) +import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.Utility import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Diagnostics @@ -72,28 +88,30 @@ import qualified System.Log.Logger as L {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- --- | A function to send a message to the client -type SendFunc = FromServerMessage -> IO () +data LanguageContextEnv config = + LanguageContextEnv + { resHandlers :: !Handlers + , resParseConfig :: !(DidChangeConfigurationNotification-> Either T.Text config) + , resSendMessage :: !(FromServerMessage -> IO ()) + , resData :: !(TVar (LanguageContextData config)) + } -- | state used by the LSP dispatcher to manage the message loop data LanguageContextData config = - LanguageContextData { - resSeqDebugContextData :: !Int - , resHandlers :: !Handlers - , resOptions :: !Options - , resSendResponse :: !SendFunc - , resVFS :: !VFSData + LanguageContextData + { resVFS :: !VFSData , resDiagnostics :: !DiagnosticStore , resConfig :: !(Maybe config) - , resLspId :: !(TVar Int) - , resLspFuncs :: LspFuncs config -- NOTE: Cannot be strict, lazy initialization - , resCaptureContext :: !CaptureContext - , resWorkspaceFolders :: ![J.WorkspaceFolder] + , resWorkspaceFolders :: ![WorkspaceFolder] , resProgressData :: !ProgressData + , resPendingResponses :: !ResponseMap + , resLspId :: !Int } +type ResponseMap = IxMap LspId (Product SMethod ServerResponseHandler) + data ProgressData = ProgressData { progressNextId :: !Int - , progressCancel :: !(Map.Map J.ProgressToken (IO ())) } + , progressCancel :: !(Map.Map ProgressToken (IO ())) } data VFSData = VFSData @@ -101,13 +119,30 @@ data VFSData = , reverseMap :: !(Map.Map FilePath FilePath) } +type LspM config = ReaderT (LanguageContextEnv config) IO + +modifyData :: (LanguageContextData config -> LanguageContextData config) -> LspM config () +modifyData f = do + tvarDat <- asks resData + liftIO $ atomically $ modifyTVar' tvarDat f + +stateData :: (LanguageContextData config -> (a,LanguageContextData config)) -> LspM config a +stateData f = do + tvarDat <- asks resData + liftIO $ atomically $ stateTVar tvarDat f + +readData :: (LanguageContextData config -> a) -> LspM config a +readData f = do + tvarDat <- asks resData + liftIO $ f <$> readTVarIO tvarDat + -- --------------------------------------------------------------------- -- | Language Server Protocol options that the server may configure. -- If you set handlers for some requests, you may need to set some of these options. data Options = Options - { textDocumentSync :: Maybe J.TextDocumentSyncOptions + { textDocumentSync :: Maybe TextDocumentSyncOptions -- | The characters that trigger completion automatically. , completionTriggerCharacters :: Maybe [Char] -- | The list of all possible characters that commit a completion. This field can be used @@ -123,7 +158,7 @@ data Options = -- | CodeActionKinds that this server may return. -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server -- may list out every specific kind they provide. - , codeActionKinds :: Maybe [J.CodeActionKind] + , codeActionKinds :: Maybe [CodeActionKind] -- | The list of characters that triggers on type formatting. -- If you set `documentOnTypeFormattingHandler`, you **must** set this. -- The first character is mandatory, so a 'NonEmpty' should be passed. @@ -142,11 +177,11 @@ instance Default Options where -- 'textDocument/publishDiagnostics' notification with the total (limited by the -- first parameter) whenever it is updated. type PublishDiagnosticsFunc = Int -- Max number of diagnostics to send - -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> IO () + -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> IO () -- | A function to remove all diagnostics from a particular source, and send the updates to the client. type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send - -> Maybe J.DiagnosticSource -> IO () + -> Maybe DiagnosticSource -> IO () -- | A package indicating the perecentage of progress complete and a -- an optional message to go with it during a 'withProgress' @@ -167,6 +202,16 @@ instance E.Exception ProgressCancelledException -- @since 0.11.0.0 data ProgressCancellable = Cancellable | NotCancellable +type SendRequestFunc = forall m. + SServerMethod (m :: Method FromServer Request) + -> MessageParams m + -> (LspId m -> Either ResponseError (ResponseParams m) -> IO ()) + -> IO (LspId m) +type SendNotifcationFunc = forall m. + SServerMethod (m :: Method FromServer Notification) + -> MessageParams m + -> IO () + -- | Returned to the server on startup, providing ways to interact with the client. data LspFuncs c = LspFuncs @@ -174,17 +219,23 @@ data LspFuncs c = , config :: !(IO (Maybe c)) -- ^ Derived from the DidChangeConfigurationNotification message via a -- server-provided function. - , sendFunc :: !SendFunc - , getVirtualFileFunc :: !(J.NormalizedUri -> IO (Maybe VirtualFile)) + , sendReq :: !SendRequestFunc + -- ^ The function used to send requests to the client and handle their + -- responses. + , sendNot :: !SendNotifcationFunc + -- ^ The function used to send notifications to the client. + , getVirtualFileFunc :: !(NormalizedUri -> IO (Maybe VirtualFile)) + , getVirtualFilesFunc :: !(IO VFS) -- ^ Function to return the 'VirtualFile' associated with a -- given 'NormalizedUri', if there is one. - , persistVirtualFileFunc :: !(J.NormalizedUri -> IO (Maybe FilePath)) + , persistVirtualFileFunc :: !(NormalizedUri -> IO (Maybe FilePath)) + , getVersionedTextDocFunc :: !(TextDocumentIdentifier -> IO VersionedTextDocumentIdentifier) + -- ^ Given a text document identifier, annotate it with the latest version. , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) , publishDiagnosticsFunc :: !PublishDiagnosticsFunc , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc - , getNextReqId :: !(IO J.LspId) , rootPath :: !(Maybe FilePath) - , getWorkspaceFolders :: !(IO (Maybe [J.WorkspaceFolder])) + , getWorkspaceFolders :: !(IO (Maybe [WorkspaceFolder])) , withProgress :: !(forall a . Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a) -- ^ Wrapper for reporting progress to the client during a long running @@ -211,546 +262,289 @@ data LspFuncs c = -- specific configuration data the language server needs to use. data InitializeCallbacks config = InitializeCallbacks - { onInitialConfiguration :: J.InitializeRequest -> Either T.Text config + { onInitialConfiguration :: InitializeRequest -> Either T.Text config -- ^ Invoked on the first message from the language client, containg the client configuration -- This callback should return either the parsed configuration data or an error indicating -- what went wrong. The parsed configuration object will be stored internally and passed to -- hanlder functions as context. - , onConfigurationChange :: J.DidChangeConfigurationNotification-> Either T.Text config + , onConfigurationChange :: DidChangeConfigurationNotification-> Either T.Text config -- ^ Invoked whenever the clients sends a message with a changed client configuration. -- This callback should return either the parsed configuration data or an error indicating -- what went wrong. The parsed configuration object will be stored internally and passed to -- hanlder functions as context. - , onStartup :: LspFuncs config -> IO (Maybe J.ResponseError) + , onStartup :: LspFuncs config -> IO (Maybe ResponseError) -- ^ Once the initial configuration has been received, this callback will be invoked to offer -- the language server implementation the chance to create any processes or start new threads -- that may be necesary for the server lifecycle. } +newtype ClientResponseHandler (m :: Method FromClient t) = ClientResponseHandler (ResponseHandlerFunc m) + +newtype ServerResponseHandler (m :: Method FromServer t) = ServerResponseHandler (ResponseHandlerFunc m) + +mkClientResponseHandler :: SClientMethod m -> ClientMessage m -> LspM config (ClientResponseHandler m) +mkClientResponseHandler m cm = do + sf <- asks resSendMessage + pure $ ClientResponseHandler $ case splitClientMethod m of + IsClientNot -> () + IsClientReq -> \mrsp -> case mrsp of + Left err -> sf $ FromServerRsp m $ makeResponseError (cm ^. J.id) err + Right rsp -> sf $ FromServerRsp m $ makeResponseMessage (cm ^. J.id) rsp + IsClientEither -> case cm of + NotMess _ -> () + ReqMess req -> \mrsp -> case mrsp of + Left err -> sf $ FromServerRsp m $ makeResponseError (req ^. J.id) err + Right rsp -> sf $ FromServerRsp m $ makeResponseMessage (req ^. J.id) rsp + +-- | Return value signals if response handler was inserted succesfully +-- Might fail if the id was already in the map +addResponseHandler :: LspId m -> (Product SMethod ServerResponseHandler) m -> LspM config Bool +addResponseHandler lid h = do + stateData $ \ctx@LanguageContextData{resPendingResponses} -> + case insertIxMap lid h resPendingResponses of + Just m -> (True, ctx { resPendingResponses = m}) + Nothing -> (False, ctx) + +mkSendNotFunc :: forall (m :: Method FromServer Notification) config. SServerMethod m -> MessageParams m -> LspM config () +mkSendNotFunc m params = + let msg = NotificationMessage "2.0" m params + in case splitServerMethod m of + IsServerNot -> sendToClient $ fromServerNot msg + IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg + +mkSendReqFunc :: forall (m :: Method FromServer Request) config. + SServerMethod m + -> MessageParams m + -> (LspId m -> Either ResponseError (ResponseParams m) -> IO ()) + -> LspM config (LspId m) +mkSendReqFunc m params resHandler = do + reqId <- IdInt <$> freshLspId + success <- addResponseHandler reqId (Pair m (ServerResponseHandler (resHandler reqId))) + unless success $ error "haskell-lsp: could not send FromServer request as id is reused" + + let msg = RequestMessage "2.0" reqId m params + ~() <- case splitServerMethod m of + IsServerReq -> sendToClient $ fromServerReq msg + IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg + return reqId + -- | The Handler type captures a function that receives local read-only state -- 'a', a function to send a reply message once encoded as a ByteString, and a -- received message of type 'b' -type Handler b = b -> IO () - --- | Callbacks from the language server to the language handler -data Handlers = - Handlers - { - -- Capability-advertised handlers - hoverHandler :: !(Maybe (Handler J.HoverRequest)) - , completionHandler :: !(Maybe (Handler J.CompletionRequest)) - , completionResolveHandler :: !(Maybe (Handler J.CompletionItemResolveRequest)) - , signatureHelpHandler :: !(Maybe (Handler J.SignatureHelpRequest)) - , 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)) - , documentSymbolHandler :: !(Maybe (Handler J.DocumentSymbolRequest)) - , workspaceSymbolHandler :: !(Maybe (Handler J.WorkspaceSymbolRequest)) - , 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)) - , documentOnTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) - , renameHandler :: !(Maybe (Handler J.RenameRequest)) - , prepareRenameHandler :: !(Maybe (Handler J.PrepareRenameRequest)) - , foldingRangeHandler :: !(Maybe (Handler J.FoldingRangeRequest)) - -- new in 3.0 - , documentLinkHandler :: !(Maybe (Handler J.DocumentLinkRequest)) - , documentLinkResolveHandler :: !(Maybe (Handler J.DocumentLinkResolveRequest)) - , executeCommandHandler :: !(Maybe (Handler J.ExecuteCommandRequest)) - -- Next 2 go from server -> client - -- , registerCapabilityHandler :: !(Maybe (Handler J.RegisterCapabilityRequest)) - -- , unregisterCapabilityHandler :: !(Maybe (Handler J.UnregisterCapabilityRequest)) - , willSaveWaitUntilTextDocHandler:: !(Maybe (Handler J.WillSaveWaitUntilTextDocumentRequest)) - - -- Notifications from the client - , didChangeConfigurationParamsHandler :: !(Maybe (Handler J.DidChangeConfigurationNotification)) - , didOpenTextDocumentNotificationHandler :: !(Maybe (Handler J.DidOpenTextDocumentNotification)) - , didChangeTextDocumentNotificationHandler :: !(Maybe (Handler J.DidChangeTextDocumentNotification)) - -- ^ Note: If you need to keep track of document changes, - -- "Language.Haskell.LSP.VFS" will take care of these messages for you! - , 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)) - , cancelNotificationHandler :: !(Maybe (Handler J.CancelNotification)) - - -- Responses to Request messages originated from the server - -- TODO: Properly decode response types and replace them with actual handlers - , responseHandler :: !(Maybe (Handler J.BareResponseMessage)) - -- , registerCapabilityHandler :: !(Maybe (Handler J.RegisterCapabilityResponse)) - -- , unregisterCapabilityHandler :: !(Maybe (Handler J.RegisterCapabilityResponse)) - -- , showMessageHandler :: !(Maybe (Handler J.ShowMessageResponse)) - - -- Initialization request on startup - , initializeRequestHandler :: !(Maybe (Handler J.InitializeRequest)) - -- Will default to terminating `exitMessage` if Nothing - , exitNotificationHandler :: !(Maybe (Handler J.ExitNotification)) - - , customRequestHandler :: !(Maybe (Handler J.CustomClientRequest)) - , customNotificationHandler :: !(Maybe (Handler J.CustomClientNotification)) - - } - -instance Default Handlers where - -- These already implicitly do stuff to the VFS, so silence warnings about no handler - def = nothings { didChangeTextDocumentNotificationHandler = Just ignore - , didOpenTextDocumentNotificationHandler = Just ignore - , didCloseTextDocumentNotificationHandler = Just ignore - } - where ignore = const (pure ()) - nothings = 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 +newtype Handler m = Handler {runHandler :: ClientMessage m -> ClientResponseHandler m -> IO ()} +type Handlers = forall t (m :: Method FromClient t). SMethod m -> Maybe (Handler m) -- --------------------------------------------------------------------- -nop :: Maybe (a -> b -> (a,[String])) +nop :: Maybe (b -> LspM config ()) nop = Nothing - -helper :: J.FromJSON a => (TVar (LanguageContextData config) -> a -> IO ()) -> (TVar (LanguageContextData config) -> J.Value -> IO ()) -helper requestHandler tvarDat json = - case J.fromJSON json of - J.Success req -> requestHandler tvarDat req - J.Error err -> do - let msg = T.pack . unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL - failLog = sendErrorLog tvarDat msg - case json of - (J.Object o) -> case HM.lookup "id" o of - Just olid -> case J.fromJSON olid of - J.Success lid -> sendErrorResponse tvarDat lid msg - _ -> failLog - _ -> failLog - _ -> failLog - -handlerMap :: (Show config) - => InitializeCallbacks config -> Handlers -> J.ClientMethod - -> (TVar (LanguageContextData config) -> J.Value -> IO ()) --- General -handlerMap i h J.Initialize = handleInitialConfig i (initializeRequestHandler h) -handlerMap _ h J.Initialized = hh nop NotInitialized $ initializedHandler h -handlerMap _ _ J.Shutdown = helper shutdownRequestHandler -handlerMap _ h J.Exit = - case exitNotificationHandler h of - Just _ -> hh nop NotExit $ exitNotificationHandler h - Nothing -> \ctxVar v -> do - ctx <- readTVarIO ctxVar - -- Capture exit notification - case J.fromJSON v :: J.Result J.ExitNotification of - J.Success n -> captureFromClient (NotExit n) (resCaptureContext ctx) - J.Error _ -> return () - logm $ B.pack "haskell-lsp:Got exit, exiting" - 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 -handlerMap _ h J.WorkspaceExecuteCommand = hh nop ReqExecuteCommand $ executeCommandHandler h --- Document -handlerMap _ h J.TextDocumentDidOpen = hh (Just openVFS) NotDidOpenTextDocument $ didOpenTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentDidChange = hh (Just changeFromClientVFS) NotDidChangeTextDocument $ didChangeTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentWillSave = hh nop NotWillSaveTextDocument $ willSaveTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentWillSaveWaitUntil = hh nop ReqWillSaveWaitUntil $ willSaveWaitUntilTextDocHandler h -handlerMap _ h J.TextDocumentDidSave = hh nop NotDidSaveTextDocument $ didSaveTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentDidClose = hh (Just closeVFS) NotDidCloseTextDocument $ didCloseTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentCompletion = hh nop ReqCompletion $ completionHandler h -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 $ typeDefinitionHandler 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 $ documentOnTypeFormattingHandler 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.TextDocumentPrepareRename = hh nop ReqPrepareRename $ prepareRenameHandler h -handlerMap _ h J.TextDocumentFoldingRange = hh nop ReqFoldingRange $ foldingRangeHandler h -handlerMap _ _ J.WorkDoneProgressCancel = helper progressCancelHandler -handlerMap _ h (J.CustomClientMethod _) = \ctxData val -> - case val of - J.Object o | "id" `HM.member` o -> - -- Custom request - hh nop ReqCustomClient (customRequestHandler h) ctxData val - _ -> -- Custom notification - hh nop NotCustomClient (customNotificationHandler h) ctxData val +handlerMap :: (Show config) => SClientMethod m -> ClientMessage m -> LspM config () +handlerMap c = case c of + SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) c + SWorkspaceDidChangeConfiguration -> hh (Just handleConfigChange) c + STextDocumentDidOpen -> hh (Just $ vfsFunc openVFS) c + STextDocumentDidChange -> hh (Just $ vfsFunc changeFromClientVFS) c + STextDocumentDidClose -> hh (Just $ vfsFunc closeVFS) c + SWorkDoneProgressCancel -> hh (Just progressCancelHandler) c + _ -> hh nop c -- --------------------------------------------------------------------- -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop -hh :: forall b config. (J.FromJSON b) - => Maybe (VFS -> b -> (VFS, [String])) -> (b -> FromClientMessage) -> Maybe (Handler b) - -> TVar (LanguageContextData config) -> J.Value -> IO () -hh mVfs wrapper mh tvarDat json = do - case J.fromJSON json of - J.Success req -> do - case mVfs of - Just modifyVfs -> do - join $ atomically $ modifyVFSData tvarDat $ \(VFSData vfs rm) -> - let (vfs', ls) = modifyVfs vfs req - in (VFSData vfs' rm, mapM_ logs ls) - Nothing -> return () - - ctx <- readTVarIO tvarDat - let req' = wrapper req - captureFromClient req' (resCaptureContext ctx) - - case mh of - Just h -> h req - Nothing - -- '$/' notifications should/could be ignored by server. - -- Don't log errors in that case. - -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. - | isOptionalNotification req' -> return () - | otherwise -> do - let msg = T.pack $ unwords ["haskell-lsp:no handler for.", show json] - sendErrorLog tvarDat msg - J.Error err -> do - let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL - sendErrorLog tvarDat msg +hh :: Maybe (ClientMessage m -> LspM config ()) -> SClientMethod m -> ClientMessage m -> LspM config () +hh mAction m req = do + maybe (return ()) (\f -> f req) mAction + getHandler <- asks resHandlers + let handleReq h = do + respH <- mkClientResponseHandler m req + liftIO $ runHandler h req respH + case getHandler m of + Just h -> handleReq h + Nothing + | SExit <- m -> handleReq exitNotificationHandler + | SShutdown <- m -> handleReq shutdownRequestHandler + -- '$/' notifications should/could be ignored by server. + -- Don't log errors in that case. + -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. + | isOptionalNotification m -> return () + | otherwise -> do + let msg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m] + sendErrorLog msg where - isOptionalNotification req - | NotCustomClient _ <- req - , J.Object object <- json - , Just (J.String method) <- HM.lookup "method" object - , "$/" `T.isPrefixOf` method - = True - | otherwise = False - -handleInitialConfig - :: (Show config) - => InitializeCallbacks config - -> Maybe (Handler J.InitializeRequest) - -> TVar (LanguageContextData config) - -> J.Value - -> IO () -handleInitialConfig (InitializeCallbacks { onInitialConfiguration, onStartup }) mh tvarDat json - = handleMessageWithConfigChange ReqInitialize - onInitialConfiguration - (Just $ initializeRequestHandler' onStartup mh tvarDat) - tvarDat - json - - -hc - :: (Show config) - => InitializeCallbacks config - -> Maybe (Handler J.DidChangeConfigurationNotification) - -> TVar (LanguageContextData config) - -> J.Value - -> IO () -hc (InitializeCallbacks { onConfigurationChange }) mh tvarDat json = - handleMessageWithConfigChange NotDidChangeConfiguration - onConfigurationChange - mh - tvarDat - json - -handleMessageWithConfigChange - :: (J.FromJSON reqParams, Show reqParams, Show err) - => (reqParams -> FromClientMessage) -- ^ The notification message from the client to expect - -> (reqParams -> Either err config) -- ^ A function to parse the config out of the request - -> Maybe (reqParams -> IO ()) -- ^ The upstream handler for the client request - -> TVar (LanguageContextData config) -- ^ The context data containing the current configuration - -> J.Value -- ^ The raw reqeust data - -> IO () -handleMessageWithConfigChange notification parseConfig mh tvarDat json = - -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification entered" - case J.fromJSON json of - J.Success req -> do - ctx <- readTVarIO tvarDat - - captureFromClient (notification req) (resCaptureContext ctx) - - case parseConfig req of - Left err -> do - let - msg = - T.pack $ unwords - ["haskell-lsp:configuration parse error.", show req, show err] - sendErrorLog tvarDat msg - Right newConfig -> - atomically $ modifyTVar' tvarDat (\ctx' -> ctx' { resConfig = Just newConfig }) - case mh of - Just h -> h req - Nothing -> return () - J.Error err -> do - 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 config) -> 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 - --- --------------------------------------------------------------------- - -modifyVFSData :: TVar (LanguageContextData config) -> (VFSData -> (VFSData, a)) -> STM a -modifyVFSData tvarDat f = do - (vfs', a) <- f . resVFS <$> readTVar tvarDat - modifyTVar tvarDat $ \vd -> vd { resVFS = vfs' } - return a + isOptionalNotification (SCustomMethod method) + | "$/" `T.isPrefixOf` method = True + isOptionalNotification _ = False + +handleConfigChange :: DidChangeConfigurationNotification -> LspM config () +handleConfigChange req = do + parseConfig <- asks resParseConfig + case parseConfig req of + Left err -> do + let msg = T.pack $ unwords + ["haskell-lsp:configuration parse error.", show req, show err] + sendErrorLog msg + Right newConfig -> + modifyData $ \ctx -> ctx { resConfig = Just newConfig } + +vfsFunc :: (VFS -> b -> (VFS, [String])) -> b -> LspM config () +vfsFunc modifyVfs req = do + join $ stateData $ \ctx@LanguageContextData{resVFS = VFSData vfs rm} -> + let (vfs', ls) = modifyVfs vfs req + in (liftIO $ mapM_ logs ls,ctx{ resVFS = VFSData vfs' rm}) + +-- | Updates the list of workspace folders +updateWorkspaceFolders :: Message WorkspaceDidChangeWorkspaceFolders -> LspM config () +updateWorkspaceFolders (NotificationMessage _ _ params) = do + let List toRemove = params ^. J.event . J.removed + List toAdd = params ^. J.event . J.added + newWfs oldWfs = foldr L.delete oldWfs toRemove <> toAdd + modifyData $ \c -> c {resWorkspaceFolders = newWfs $ resWorkspaceFolders c} -- --------------------------------------------------------------------- -- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. -getVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe VirtualFile) -getVirtualFile tvarDat uri = Map.lookup uri . vfsMap . vfsData . resVFS <$> readTVarIO tvarDat +getVirtualFile :: NormalizedUri -> LspM config (Maybe VirtualFile) +getVirtualFile uri = readData $ Map.lookup uri . vfsMap . vfsData . resVFS + +getVirtualFiles :: LspM config VFS +getVirtualFiles = readData $ vfsData . resVFS -- | Dump the current text for a given VFS file to a temporary file, -- and return the path to the file. -persistVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe FilePath) -persistVirtualFile tvarDat uri = join $ atomically $ do - st <- readTVar tvarDat - let vfs_data = resVFS st - cur_vfs = vfsData vfs_data - revMap = reverseMap vfs_data - - case persistFileVFS cur_vfs uri of - Nothing -> return (return Nothing) - Just (fn, write) -> do - let revMap' = - -- TODO: Does the VFS make sense for URIs which are not files? - -- The reverse map should perhaps be (FilePath -> URI) - case J.uriToFilePath (J.fromNormalizedUri uri) of - Just uri_fp -> Map.insert fn uri_fp revMap - Nothing -> revMap - - modifyVFSData tvarDat (\d -> (d { reverseMap = revMap' }, ())) - return ((Just fn) <$ write) +persistVirtualFile :: NormalizedUri -> LspM config (Maybe FilePath) +persistVirtualFile uri = do + join $ stateData $ \ctx@LanguageContextData{resVFS = vfs} -> + case persistFileVFS (vfsData vfs) uri of + Nothing -> (return Nothing, ctx) + Just (fn, write) -> + let revMap = case uriToFilePath (fromNormalizedUri uri) of + Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs + -- TODO: Does the VFS make sense for URIs which are not files? + -- The reverse map should perhaps be (FilePath -> URI) + Nothing -> reverseMap vfs + act = do + liftIO write + pure (Just fn) + in (act, ctx{resVFS = vfs {reverseMap = revMap} }) + +getVersionedTextDoc :: TextDocumentIdentifier -> LspM config VersionedTextDocumentIdentifier +getVersionedTextDoc doc = do + let uri = doc ^. J.uri + mvf <- getVirtualFile (toNormalizedUri uri) + let ver = case mvf of + Just (VirtualFile lspver _ _) -> Just lspver + Nothing -> Nothing + return (VersionedTextDocumentIdentifier uri ver) -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map -- the temporary file name back to the original one. -reverseFileMap :: TVar (LanguageContextData config) - -> IO (FilePath -> FilePath) -reverseFileMap tvarDat = do - vfs <- resVFS <$> readTVarIO tvarDat - let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs - return f +reverseFileMap :: LspM config (FilePath -> FilePath) +reverseFileMap = do + vfs <- readData resVFS + let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs + return f -- --------------------------------------------------------------------- -getConfig :: TVar (LanguageContextData config) -> IO (Maybe config) -getConfig tvar = resConfig <$> readTVarIO tvar +getConfig :: LspM config (Maybe config) +getConfig = readData resConfig -- --------------------------------------------------------------------- --- | --- --- -_INITIAL_RESPONSE_SEQUENCE :: Int -_INITIAL_RESPONSE_SEQUENCE = 0 - - --- | --- --- -_SEP_WIN :: Char -_SEP_WIN = '\\' --- | --- --- -_SEP_UNIX :: Char -_SEP_UNIX = '/' - --- | --- --- _ERR_MSG_URL :: [String] _ERR_MSG_URL = [ "`stack update` and install new haskell-lsp." , "Or check information on https://marketplace.visualstudio.com/items?itemName=xxxxxxxxxxxxxxx" ] - --- | --- --- -defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> CaptureContext -> VFS -> LanguageContextData config -defaultLanguageContextData h o lf tv sf cc vfs = - LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf (VFSData vfs mempty) mempty - Nothing tv lf cc mempty defaultProgressData - defaultProgressData :: ProgressData defaultProgressData = ProgressData 0 Map.empty -- --------------------------------------------------------------------- -handleMessage :: (Show config) => InitializeCallbacks config - -> TVar (LanguageContextData config) -> BSL.ByteString -> IO () -handleMessage dispatcherProc tvarDat jsonStr = do - {- - Message Types we must handle are the following - - Request | jsonrpc | id | method | params? - Response | jsonrpc | id | | | response? | error? - Notification | jsonrpc | | method | params? - - -} - - case J.eitherDecode jsonStr :: Either String J.Object of - Left err -> do - let msg = T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) - ++ "\n" - sendErrorLog tvarDat msg - - Right o -> do - - case HM.lookup "method" o of - Just cmd@(J.String s) -> case J.fromJSON cmd of - J.Success m -> handle (J.Object o) m - J.Error _ -> do - let msg = T.pack $ unwords ["haskell-lsp:unknown message received:method='" - ++ T.unpack s ++ "',", lbs2str jsonStr] - sendErrorLog tvarDat msg - Just oops -> logs $ "haskell-lsp:got strange method param, ignoring:" ++ show oops - Nothing -> do - logs $ "haskell-lsp:Got reply message:" ++ show jsonStr - handleResponse (J.Object o) - +handleMessage :: (Show config) => BSL.ByteString -> LspM config () +handleMessage jsonStr = do + tvarDat <- asks resData + join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do + val <- except $ J.eitherDecode jsonStr + ctx <- lift $ readTVar tvarDat + msg <- except $ J.parseEither (parser $ resPendingResponses ctx) val + lift $ case msg of + FromClientMess m mess -> + pure $ handlerMap m mess + FromClientRsp (Pair (ServerResponseHandler f) (Const newMap)) res -> do + modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap }) + pure $ liftIO $ f (res ^. J.result) where - handleResponse json = do - ctx <- readTVarIO tvarDat - case responseHandler $ resHandlers ctx of - Nothing -> sendErrorLog tvarDat $ T.pack $ "haskell-lsp: responseHandler is not defined, ignoring response " ++ lbs2str jsonStr - Just h -> case J.fromJSON json of - J.Success res -> h res - J.Error err -> let msg = T.pack $ unwords $ ["haskell-lsp:response parse error.", lbs2str jsonStr, show err] ++ _ERR_MSG_URL - in sendErrorLog tvarDat msg - -- capability based handlers - handle json cmd = do - ctx <- readTVarIO tvarDat - let h = resHandlers ctx - handlerMap dispatcherProc h cmd tvarDat json - --- --------------------------------------------------------------------- + parser :: ResponseMap -> J.Value -> J.Parser (FromClientMessage' (Product ServerResponseHandler (Const ResponseMap))) + parser rm = parseClientMessage $ \i -> + let (mhandler, newMap) = pickFromIxMap i rm + in (\(Pair m handler) -> (m,Pair handler (Const newMap))) <$> mhandler -makeResponseMessage :: J.RequestMessage J.ClientMethod req resp -> resp -> J.ResponseMessage resp -makeResponseMessage req result = J.ResponseMessage "2.0" (J.responseId $ req ^. J.id) (Right result) + handleErrors = either (sendErrorLog . errMsg) id -makeResponseError :: J.LspIdRsp -> J.ResponseError -> J.ResponseMessage () -makeResponseError origId err = J.ResponseMessage "2.0" origId (Left err) + errMsg err = T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str jsonStr, show err] + ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) + ++ "\n" -- --------------------------------------------------------------------- --- | --- -sendEvent :: TVar (LanguageContextData config) -> FromServerMessage -> IO () -sendEvent tvarCtx msg = sendResponse tvarCtx msg --- | --- -sendResponse :: TVar (LanguageContextData config) -> FromServerMessage -> IO () -sendResponse tvarCtx msg = do - ctx <- readTVarIO tvarCtx - resSendResponse ctx msg +makeResponseMessage :: LspId m -> ResponseParams m -> ResponseMessage m +makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) +makeResponseError :: LspId m -> ResponseError -> ResponseMessage m +makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) -- --------------------------------------------------------------------- --- | --- --- -sendErrorResponse :: TVar (LanguageContextData config) -> J.LspIdRsp -> Text -> IO () -sendErrorResponse tv origId msg = sendErrorResponseS (sendEvent tv) origId J.InternalError msg - -sendErrorResponseS :: SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO () -sendErrorResponseS sf origId err msg = do - sf $ RspError (J.ResponseMessage "2.0" origId - (Left $ J.ResponseError err msg Nothing) :: J.ErrorResponse) - -sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO () -sendErrorLog tv msg = sendErrorLogS (sendEvent tv) msg -sendErrorLogS :: SendFunc -> Text -> IO () -sendErrorLogS sf msg = - sf $ NotLogMessage $ fmServerLogMessageNotification J.MtError msg +sendToClient :: FromServerMessage -> LspM config () +sendToClient msg = do + f <- asks resSendMessage + liftIO $ f msg --- sendErrorShow :: String -> IO () --- sendErrorShow msg = sendErrorShowS sendEvent msg +-- --------------------------------------------------------------------- -sendErrorShowS :: SendFunc -> Text -> IO () -sendErrorShowS sf msg = - sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError msg +sendErrorLog :: Text -> LspM config () +sendErrorLog msg = + sendToClient $ fromServerNot $ + NotificationMessage "2.0" SWindowLogMessage (LogMessageParams MtError msg) -- --------------------------------------------------------------------- -defaultErrorHandlers :: (Show a) => TVar (LanguageContextData config) -> J.LspIdRsp -> a -> [E.Handler ()] -defaultErrorHandlers tvarDat origId req = [ E.Handler someExcept ] +initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) +initializeErrorHandler sendResp e = do + sendResp $ ResponseError InternalError msg Nothing + pure Nothing where - someExcept (e :: E.SomeException) = do - let msg = T.pack $ unwords ["request error.", show req, show e] - sendErrorResponse tvarDat origId msg - sendErrorLog tvarDat msg - + msg = T.pack $ unwords ["Error on initialize:", show e] -- |===================================================================== -- -- Handlers --- | --- -initializeRequestHandler' - :: (Show config) - => (LspFuncs config -> IO (Maybe J.ResponseError)) - -> Maybe (Handler J.InitializeRequest) - -> TVar (LanguageContextData config) - -> J.InitializeRequest - -> IO () -initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ origId _ params) = - flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do - - case mHandler of - Just handler -> handler req - Nothing -> return () +freshLspId :: LspM config Int +freshLspId = do + stateData $ \c -> + (resLspId c, c{resLspId = resLspId c+1}) - let wfs = case params ^. J.workspaceFolders of - Just (J.List xs) -> xs - Nothing -> [] - - atomically $ modifyTVar' tvarCtx (\c -> c { resWorkspaceFolders = wfs }) - - ctx0 <- readTVarIO tvarCtx - let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= J.uriToFilePath +-- | Call this to initialize the session +initializeRequestHandler + :: forall config. (Show config) + => InitializeCallbacks config + -> VFS + -> Handlers + -> Options + -> (FromServerMessage -> IO ()) + -> Message Initialize + -> IO (Maybe (LanguageContextEnv config)) +initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc req = do + let sendResp = sendFunc . FromServerRsp SInitialize + flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. J.id)) $ do + + let params = req ^. J.params + + let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= uriToFilePath , params ^. J.rootPath <&> T.unpack ] case rootDir of @@ -760,13 +554,6 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori unless (null dir) $ setCurrentDirectory dir let - getCapabilities :: J.InitializeParams -> C.ClientCapabilities - 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 @@ -780,111 +567,136 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori (C.WindowClientCapabilities mProgress) <- wc mProgress - storeProgress :: J.ProgressToken -> Async a -> IO () - storeProgress n a = atomically $ do - pd <- resProgressData <$> readTVar tvarCtx - let pc = progressCancel pd - pc' = Map.insert n (cancelWith a ProgressCancelledException) pc - modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressCancel = pc' }}) - - deleteProgress :: J.ProgressToken -> IO () - deleteProgress n = atomically $ do - pd <- resProgressData <$> readTVar tvarCtx - let x = progressCancel pd - x' = Map.delete n x - modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressCancel = x' }}) - - -- Get a new id for the progress session and make a new one - getNewProgressId :: IO J.ProgressToken - getNewProgressId = liftIO $ atomically $ do - pd <- resProgressData <$> readTVar tvarCtx - let x = progressNextId pd - modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressNextId = x + 1 }}) - return $ J.ProgressNumericToken x - - withProgressBase :: Bool -> (Text -> ProgressCancellable - -> ((Progress -> IO ()) -> IO a) -> IO a) - withProgressBase indefinite title cancellable f - | clientSupportsProgress = do - let sf = sendResponse tvarCtx - - progId <- getNewProgressId - - let initialPercentage - | indefinite = Nothing - | otherwise = Just 0 - cancellable' = case cancellable of - Cancellable -> True - NotCancellable -> False - - rId <- getLspId $ resLspId ctx0 - - -- Create progress token - liftIO $ sf $ ReqWorkDoneProgressCreate $ - fmServerWorkDoneProgressCreateRequest rId $ J.WorkDoneProgressCreateParams progId - - -- Send initial notification - liftIO $ sf $ NotWorkDoneProgressBegin $ fmServerWorkDoneProgressBeginNotification $ - J.ProgressParams progId $ - J.WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage - - aid <- async $ f (updater progId sf) - storeProgress progId aid - res <- wait aid - - -- Send done notification - liftIO $ sf $ NotWorkDoneProgressEnd $ fmServerWorkDoneProgressEndNotification $ - J.ProgressParams progId $ - J.WorkDoneProgressEndParams Nothing - -- Delete the progress cancellation from the map - -- If we don't do this then it's easy to leak things as the map contains any IO action. - deleteProgress progId - - - return res - | otherwise = f (const $ return ()) - where updater progId sf (Progress percentage msg) = - sf $ NotWorkDoneProgressReport $ fmServerWorkDoneProgressReportNotification $ - J.ProgressParams progId $ - J.WorkDoneProgressReportParams Nothing msg percentage - - withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a - withProgress' = withProgressBase False - - withIndefiniteProgress' :: Text -> ProgressCancellable -> IO a -> IO a - withIndefiniteProgress' title cancellable f = - withProgressBase True title cancellable (const f) + + let wfs = case params ^. J.workspaceFolders of + Just (List xs) -> xs + Nothing -> [] + initialConfigRes = onInitialConfiguration req + initialConfig = either (const Nothing) Just initialConfigRes + + tvarCtx <- newTVarIO $ LanguageContextData (VFSData vfs mempty) mempty initialConfig wfs defaultProgressData emptyIxMap 0 -- Launch the given process once the project root directory has been set - let lspFuncs = LspFuncs (getCapabilities params) - (getConfig tvarCtx) - (resSendResponse ctx0) - (getVirtualFile tvarCtx) - (persistVirtualFile tvarCtx) - (reverseFileMap tvarCtx) - (publishDiagnostics tvarCtx) - (flushDiagnosticsBySource tvarCtx) - (getLspId $ resLspId ctx0) + let lspFuncs = LspFuncs (params ^. J.capabilities) + (runReaderT getConfig env) + (\a b c -> flip runReaderT env $ mkSendReqFunc a b c) + (\a b -> flip runReaderT env $ mkSendNotFunc a b) + (flip runReaderT env . getVirtualFile) + (flip runReaderT env getVirtualFiles) + (flip runReaderT env . persistVirtualFile) + (flip runReaderT env . getVersionedTextDoc) + (runReaderT reverseFileMap env) + (\a b c d -> flip runReaderT env $ publishDiagnostics a b c d) + (\a b -> flip runReaderT env $ flushDiagnosticsBySource a b) rootDir (getWfs tvarCtx) - withProgress' - withIndefiniteProgress' - atomically $ modifyTVar tvarCtx (\cur_ctx -> cur_ctx { resLspFuncs = lspFuncs }) - - ctx <- readTVarIO tvarCtx + withProgressFunc + withIndefiniteProgressFunc + env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx + + withProgressFunc :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a + withProgressFunc t c f + | clientSupportsProgress = flip runReaderT env $ withProgress' t c f + | otherwise = f (const $ return ()) + withIndefiniteProgressFunc :: Text -> ProgressCancellable -> IO a -> IO a + withIndefiniteProgressFunc t c f + | clientSupportsProgress = flip runReaderT env $ withIndefiniteProgress' t c f + | otherwise = f initializationResult <- onStartup lspFuncs - case initializationResult of Just errResp -> do - sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp - + sendResp $ makeResponseError (req ^. J.id) errResp Nothing -> do - let capa = serverCapabilities (getCapabilities params) (resOptions ctx) (resHandlers ctx) - -- TODO: wrap this up into a fn to create a response message - res = J.ResponseMessage "2.0" (J.responseId origId) (Right $ J.InitializeResponseCapabilities capa) - - sendResponse tvarCtx $ RspInitialize res + let capa = serverCapabilities (params ^. J.capabilities) options handlers + sendResp $ makeResponseMessage (req ^. J.id) (InitializeResponseCapabilities capa) + + + case initialConfigRes of + Right _ -> pure () + Left err -> do + let msg = T.pack $ unwords + ["haskell-lsp:configuration parse error.", show req, show err] + runReaderT (sendErrorLog msg) env + + return $ Just env + +-------------------------------------------------------------------------------- +-- PROGRESS +-------------------------------------------------------------------------------- + +storeProgress :: ProgressToken -> Async a -> LspM config () +storeProgress n a = do + let f = Map.insert n (cancelWith a ProgressCancelledException) . progressCancel + modifyData $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} + +deleteProgress :: ProgressToken -> LspM config () +deleteProgress n = do + let f = Map.delete n . progressCancel + modifyData $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} + +-- Get a new id for the progress session and make a new one +getNewProgressId :: LspM config ProgressToken +getNewProgressId = do + stateData $ \ctx@LanguageContextData{resProgressData} -> + let x = progressNextId resProgressData + ctx' = ctx { resProgressData = resProgressData { progressNextId = x + 1 }} + in (ProgressNumericToken x, ctx') + +withProgressBase :: Bool -> Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> LspM config a +withProgressBase indefinite title cancellable f = do + env <- ask + let sf x = runReaderT (sendToClient x) env + + progId <- getNewProgressId + + let initialPercentage + | indefinite = Nothing + | otherwise = Just 0 + cancellable' = case cancellable of + Cancellable -> True + NotCancellable -> False + + -- Create progress token + -- FIXME : This needs to wait until the request returns before + -- continuing!!! + _ <- mkSendReqFunc SWindowWorkDoneProgressCreate + (WorkDoneProgressCreateParams progId) $ \_ res -> do + case res of + -- An error ocurred when the client was setting it up + -- No need to do anything then, as per the spec + Left _err -> pure () + Right () -> pure () + + -- Send initial notification + mkSendNotFunc SProgress $ + fmap Begin $ ProgressParams progId $ + WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage + + aid <- liftIO $ async $ f (updater progId (sf . fromServerNot)) + storeProgress progId aid + res <- liftIO $ wait aid + + -- Send done notification + mkSendNotFunc SProgress $ + End <$> (ProgressParams progId (WorkDoneProgressEndParams Nothing)) + -- Delete the progress cancellation from the map + -- If we don't do this then it's easy to leak things as the map contains any IO action. + deleteProgress progId + + + return res + where updater progId sf (Progress percentage msg) = + sf $ NotificationMessage "2.0" SProgress $ + fmap Report $ ProgressParams progId $ + WorkDoneProgressReportParams Nothing msg percentage + +withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> LspM config a +withProgress' = withProgressBase False + +withIndefiniteProgress' :: Text -> ProgressCancellable -> IO a -> LspM config a +withIndefiniteProgress' title cancellable f = + withProgressBase True title cancellable (const f) -- | Infers the capabilities based on registered handlers, and sets the appropriate options. -- A provider should be set to Nothing if the server does not support it, unless it is a @@ -893,45 +705,51 @@ serverCapabilities :: C.ClientCapabilities -> Options -> Handlers -> J.Initializ serverCapabilities clientCaps o h = J.InitializeResponseCapabilitiesInner { J._textDocumentSync = sync - , J._hoverProvider = supported (hoverHandler h) + , J._hoverProvider = supported J.STextDocumentHover , J._completionProvider = completionProvider , J._signatureHelpProvider = signatureHelpProvider - , J._definitionProvider = supported (definitionHandler h) - , J._typeDefinitionProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h - , J._implementationProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h - , J._referencesProvider = supported (referencesHandler h) - , J._documentHighlightProvider = supported (documentHighlightHandler h) - , J._documentSymbolProvider = supported (documentSymbolHandler h) - , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) + , J._definitionProvider = supported J.STextDocumentDefinition + , J._typeDefinitionProvider = Just $ J.GotoOptionsStatic $ supported_b J.STextDocumentTypeDefinition + , J._implementationProvider = Just $ J.GotoOptionsStatic $ supported_b J.STextDocumentImplementation + , J._referencesProvider = supported J.STextDocumentReferences + , J._documentHighlightProvider = supported J.STextDocumentDocumentHighlight + , J._documentSymbolProvider = supported J.STextDocumentDocumentSymbol + , J._workspaceSymbolProvider = supported J.SWorkspaceSymbol , J._codeActionProvider = codeActionProvider - , J._codeLensProvider = supported' (codeLensHandler h) $ J.CodeLensOptions $ - supported (codeLensResolveHandler h) - , J._documentFormattingProvider = supported (documentFormattingHandler h) - , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) + , J._codeLensProvider = supported' J.STextDocumentCodeLens $ J.CodeLensOptions $ + supported J.SCodeLensResolve + , J._documentFormattingProvider = supported J.STextDocumentFormatting + , J._documentRangeFormattingProvider = supported J.STextDocumentRangeFormatting , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider - , J._renameProvider = Just $ J.RenameOptionsStatic $ isJust $ renameHandler h - , J._documentLinkProvider = supported' (documentLinkHandler h) $ J.DocumentLinkOptions $ - Just $ isJust $ documentLinkResolveHandler h - , J._colorProvider = Just $ J.ColorOptionsStatic $ isJust $ documentColorHandler h - , J._foldingRangeProvider = Just $ J.FoldingRangeOptionsStatic $ isJust $ foldingRangeHandler h + , J._renameProvider = Just $ J.RenameOptionsStatic $ supported_b J.STextDocumentRename + , J._documentLinkProvider = supported' J.STextDocumentDocumentLink $ J.DocumentLinkOptions $ + supported J.SDocumentLinkResolve + , J._colorProvider = Just $ J.ColorOptionsStatic $ supported_b J.STextDocumentDocumentColor + , J._foldingRangeProvider = Just $ J.FoldingRangeOptionsStatic $ supported_b J.STextDocumentFoldingRange , J._executeCommandProvider = executeCommandProvider , J._workspace = Just workspace -- TODO: Add something for experimental , J._experimental = Nothing :: Maybe J.Value } where - supported x = supported' x True - supported' (Just _) = Just - supported' Nothing = const Nothing + supported' m b + | supported_b m = Just b + | otherwise = Nothing + + supported :: forall m. J.SClientMethod m -> Maybe Bool + supported = Just . supported_b + + supported_b :: forall m. J.SClientMethod m -> Bool + supported_b m = isJust (h m) singleton :: a -> [a] singleton x = [x] completionProvider - | isJust $ completionHandler h = Just $ + | supported_b J.STextDocumentCompletion = Just $ J.CompletionOptions - (Just $ isJust $ completionResolveHandler h) + (supported J.SCompletionItemResolve) (map singleton <$> completionTriggerCharacters o) (map singleton <$> completionAllCommitCharacters o) | otherwise = Nothing @@ -941,30 +759,30 @@ serverCapabilities clientCaps o h = codeActionProvider | clientSupportsCodeActionKinds - , isJust $ codeActionHandler h = Just $ maybe (J.CodeActionOptionsStatic True) (J.CodeActionOptions . Just) (codeActionKinds o) - | isJust $ codeActionHandler h = Just (J.CodeActionOptionsStatic True) + , supported_b J.STextDocumentCodeAction = Just $ maybe (J.CodeActionOptionsStatic True) (J.CodeActionOptions . Just) (codeActionKinds o) + | supported_b J.STextDocumentCodeAction = Just (J.CodeActionOptionsStatic True) | otherwise = Just (J.CodeActionOptionsStatic False) signatureHelpProvider - | isJust $ signatureHelpHandler h = Just $ + | supported_b J.STextDocumentSignatureHelp = Just $ J.SignatureHelpOptions (map singleton <$> signatureHelpTriggerCharacters o) (map singleton <$> signatureHelpRetriggerCharacters o) | otherwise = Nothing documentOnTypeFormattingProvider - | isJust $ documentOnTypeFormattingHandler h + | supported_b J.STextDocumentOnTypeFormatting , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ J.DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) - | isJust $ documentOnTypeFormattingHandler h + | supported_b J.STextDocumentOnTypeFormatting , Nothing <- documentOnTypeFormattingTriggerCharacters o = error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" | otherwise = Nothing executeCommandProvider - | isJust $ executeCommandHandler h + | supported_b J.SWorkspaceExecuteCommand , Just cmds <- executeCommandCommands o = Just (J.ExecuteCommandOptions (J.List cmds)) - | isJust $ executeCommandHandler h + | supported_b J.SWorkspaceExecuteCommand , Nothing <- executeCommandCommands o = error "executeCommandCommands needs to be set if a executeCommandHandler is set" | otherwise = Nothing @@ -974,65 +792,58 @@ serverCapabilities clientCaps o h = Nothing -> Nothing workspace = J.WorkspaceOptions workspaceFolder - workspaceFolder = case didChangeWorkspaceFoldersNotificationHandler h of - Just _ -> Just $ + workspaceFolder = supported' J.SWorkspaceDidChangeWorkspaceFolders $ -- sign up to receive notifications J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True)) - Nothing -> Nothing -progressCancelHandler :: TVar (LanguageContextData config) -> J.WorkDoneProgressCancelNotification -> IO () -progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do - mact <- Map.lookup tid . progressCancel . resProgressData <$> readTVarIO tvarCtx +progressCancelHandler :: J.WorkDoneProgressCancelNotification -> LspM config () +progressCancelHandler (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do + mact <- readData $ Map.lookup tid . progressCancel . resProgressData case mact of Nothing -> return () - Just cancelAction -> cancelAction - + Just cancelAction -> liftIO $ cancelAction --- | --- -shutdownRequestHandler :: TVar (LanguageContextData config) -> J.ShutdownRequest -> IO () -shutdownRequestHandler tvarCtx req@(J.RequestMessage _ origId _ _) = - flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do - let res = makeResponseMessage req Nothing +exitNotificationHandler :: Handler J.Exit +exitNotificationHandler = Handler $ \_ _ -> do + logm $ B.pack "haskell-lsp:Got exit, exiting" + exitSuccess - sendResponse tvarCtx $ RspShutdown res +-- | Default Shutdown handler +shutdownRequestHandler :: Handler J.Shutdown +shutdownRequestHandler = Handler $ \_req (ClientResponseHandler k) -> do + k $ Right J.Empty -- --------------------------------------------------------------------- -- | Take the new diagnostics, update the stored diagnostics for the given file -- and version, and publish the total to the client. -publishDiagnostics :: TVar (LanguageContextData config) -> PublishDiagnosticsFunc -publishDiagnostics tvarDat maxDiagnosticCount uri version diags = do - join $ atomically $ do - ctx <- readTVar tvarDat - let ds = updateDiagnostics (resDiagnostics ctx) uri version diags - writeTVar tvarDat $ ctx{resDiagnostics = ds} - let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri - return $ case mdp of - Nothing -> return () - Just params -> - resSendResponse ctx $ NotPublishDiagnostics - $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params +publishDiagnostics :: Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> LspM config () +publishDiagnostics maxDiagnosticCount uri version diags = join $ stateData $ \ctx -> + let ds = updateDiagnostics (resDiagnostics ctx) uri version diags + ctx' = ctx{resDiagnostics = ds} + mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri + act = case mdp of + Nothing -> return () + Just params -> + sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params + in (act,ctx') -- --------------------------------------------------------------------- -- | Take the new diagnostics, update the stored diagnostics for the given file -- and version, and publish the total to the client. -flushDiagnosticsBySource :: TVar (LanguageContextData config) -> FlushDiagnosticsBySourceFunc -flushDiagnosticsBySource tvarDat maxDiagnosticCount msource = join $ atomically $ do - -- logs $ "haskell-lsp:flushDiagnosticsBySource:source=" ++ show source - ctx <- readTVar tvarDat +flushDiagnosticsBySource :: Int -> Maybe DiagnosticSource -> LspM config () +flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateData $ \ctx -> let ds = flushBySource (resDiagnostics ctx) msource - writeTVar tvarDat $ ctx {resDiagnostics = ds} - -- Send the updated diagnostics to the client - return $ forM_ (HM.keys ds) $ \uri -> do - -- logs $ "haskell-lsp:flushDiagnosticsBySource:uri=" ++ show uri - let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri - case mdp of - Nothing -> return () - Just params -> do - resSendResponse ctx $ NotPublishDiagnostics - $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params + ctx' = ctx {resDiagnostics = ds} + -- Send the updated diagnostics to the client + act = forM_ (HM.keys ds) $ \uri -> do + let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri + case mdp of + Nothing -> return () + Just params -> do + sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params + in (act,ctx') -- ===================================================================== -- diff --git a/src/Language/Haskell/LSP/Messages.hs b/src/Language/Haskell/LSP/Messages.hs deleted file mode 100644 index c15119036..000000000 --- a/src/Language/Haskell/LSP/Messages.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} - -module Language.Haskell.LSP.Messages - ( module Language.Haskell.LSP.Types.MessageFuncs - , FromClientMessage(..) - , FromServerMessage(..) - ) -where - -import Language.Haskell.LSP.Types.MessageFuncs -import Language.Haskell.LSP.Types -import GHC.Generics -import Data.Aeson - --- | A wrapper around a message that originates from the client --- and is sent to the server. -data FromClientMessage = ReqInitialize InitializeRequest - | ReqShutdown ShutdownRequest - | ReqHover HoverRequest - | ReqCompletion CompletionRequest - | ReqCompletionItemResolve CompletionItemResolveRequest - | ReqSignatureHelp SignatureHelpRequest - | ReqDefinition DefinitionRequest - | ReqTypeDefinition TypeDefinitionRequest - | ReqImplementation ImplementationRequest - | ReqFindReferences ReferencesRequest - | ReqDocumentHighlights DocumentHighlightRequest - | ReqDocumentSymbols DocumentSymbolRequest - | ReqWorkspaceSymbols WorkspaceSymbolRequest - | ReqCodeAction CodeActionRequest - | ReqCodeLens CodeLensRequest - | ReqCodeLensResolve CodeLensResolveRequest - | ReqDocumentLink DocumentLinkRequest - | ReqDocumentLinkResolve DocumentLinkResolveRequest - | ReqDocumentColor DocumentColorRequest - | ReqColorPresentation ColorPresentationRequest - | ReqDocumentFormatting DocumentFormattingRequest - | ReqDocumentRangeFormatting DocumentRangeFormattingRequest - | ReqDocumentOnTypeFormatting DocumentOnTypeFormattingRequest - | ReqRename RenameRequest - | ReqPrepareRename PrepareRenameRequest - | ReqFoldingRange FoldingRangeRequest - | ReqExecuteCommand ExecuteCommandRequest - | ReqWillSaveWaitUntil WillSaveWaitUntilTextDocumentRequest - -- Responses - | RspApplyWorkspaceEdit ApplyWorkspaceEditResponse - -- TODO: Remove this and properly decode the type of responses - -- based on the id - | RspFromClient BareResponseMessage - -- Notifications - | NotInitialized InitializedNotification - | NotExit ExitNotification - -- A cancel request notification is duplex! - | NotCancelRequestFromClient CancelNotification - | NotDidChangeConfiguration DidChangeConfigurationNotification - | NotDidOpenTextDocument DidOpenTextDocumentNotification - | NotDidChangeTextDocument DidChangeTextDocumentNotification - | NotDidCloseTextDocument DidCloseTextDocumentNotification - | NotWillSaveTextDocument WillSaveTextDocumentNotification - | NotDidSaveTextDocument DidSaveTextDocumentNotification - | NotDidChangeWatchedFiles DidChangeWatchedFilesNotification - | NotDidChangeWorkspaceFolders DidChangeWorkspaceFoldersNotification - | NotWorkDoneProgressCancel WorkDoneProgressCancelNotification - - -- It is common for language servers to add custom message types so these - -- three constructors can be used to handle custom request, response or notification - -- types. - | ReqCustomClient CustomClientRequest - | NotCustomClient CustomClientNotification - deriving (Eq,Read,Show,Generic,ToJSON,FromJSON) - --- | A wrapper around a message that originates from the server --- and is sent to the client. -data FromServerMessage = ReqRegisterCapability RegisterCapabilityRequest - | ReqUnregisterCapability UnregisterCapabilityRequest - | ReqApplyWorkspaceEdit ApplyWorkspaceEditRequest - | ReqShowMessage ShowMessageRequest - | ReqWorkDoneProgressCreate WorkDoneProgressCreateRequest - -- Responses - | RspInitialize InitializeResponse - | RspShutdown ShutdownResponse - | RspHover HoverResponse - | RspCompletion CompletionResponse - | RspCompletionItemResolve CompletionItemResolveResponse - | RspSignatureHelp SignatureHelpResponse - | RspDefinition DefinitionResponse - | RspTypeDefinition TypeDefinitionResponse - | RspImplementation ImplementationResponse - | RspFindReferences ReferencesResponse - | RspDocumentHighlights DocumentHighlightsResponse - | RspDocumentSymbols DocumentSymbolsResponse - | RspWorkspaceSymbols WorkspaceSymbolsResponse - | 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 - | RspWillSaveWaitUntil WillSaveWaitUntilTextDocumentResponse - -- Notifications - | NotPublishDiagnostics PublishDiagnosticsNotification - | NotLogMessage LogMessageNotification - | NotShowMessage ShowMessageNotification - | NotWorkDoneProgressBegin WorkDoneProgressBeginNotification - | NotWorkDoneProgressReport WorkDoneProgressReportNotification - | NotWorkDoneProgressEnd WorkDoneProgressEndNotification - | NotTelemetry TelemetryNotification - -- A cancel request notification is duplex! - | NotCancelRequestFromServer CancelNotificationServer - - -- It is common for language servers to add custom message types so these - -- three constructors can be used to handle custom request, response or notification - -- types. - | ReqCustomServer CustomServerRequest - | RspCustomServer CustomResponse - | NotCustomServer CustomServerNotification - deriving (Eq,Read,Show,Generic,ToJSON,FromJSON) diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs index 994827c04..062efbaee 100644 --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -158,7 +158,7 @@ changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do let sortedEdits = sortOn (Down . (^. J.range)) edits changeEvents = map editToChangeEvent sortedEdits ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) - notif = J.NotificationMessage "" J.TextDocumentDidChange ps + notif = J.NotificationMessage "" J.STextDocumentDidChange ps let (vfs',ls) = changeFromClientVFS vfs notif mapM_ logs ls return vfs' From bf4c2c93f6a433c86e74435078b55f9d55eb0a6d Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 17 May 2020 20:38:57 +0100 Subject: [PATCH 02/63] Reworking options and server capabilities WIP --- .gitignore | 1 + haskell-lsp-types/haskell-lsp-types.cabal | 9 + .../src/Language/Haskell/LSP/Types.hs | 2 + .../Haskell/LSP/Types/ClientCapabilities.hs | 16 +- .../Language/Haskell/LSP/Types/CodeAction.hs | 36 + .../Language/Haskell/LSP/Types/CodeLens.hs | 166 ++ .../src/Language/Haskell/LSP/Types/Color.hs | 20 +- .../src/Language/Haskell/LSP/Types/Command.hs | 23 + .../Language/Haskell/LSP/Types/Completion.hs | 48 + .../Haskell/LSP/Types/DataTypesJSON.hs | 1458 ++--------------- .../Haskell/LSP/Types/DocumentHighlight.hs | 112 ++ .../src/Language/Haskell/LSP/Types/Empty.hs | 10 + .../Haskell/LSP/Types/FoldingRange.hs | 20 + .../Language/Haskell/LSP/Types/Formatting.hs | 271 +++ .../src/Language/Haskell/LSP/Types/Hover.hs | 18 + .../src/Language/Haskell/LSP/Types/Lens.hs | 20 +- .../src/Language/Haskell/LSP/Types/Message.hs | 17 +- .../src/Language/Haskell/LSP/Types/Method.hs | 4 + .../Language/Haskell/LSP/Types/Progress.hs | 325 +++- .../Language/Haskell/LSP/Types/References.hs | 83 + .../Haskell/LSP/Types/Registration.hs | 189 +++ .../src/Language/Haskell/LSP/Types/Rename.hs | 147 ++ .../Haskell/LSP/Types/ServerCapabilities.hs | 560 +++++++ .../LSP/Types/StaticRegistrationOptions.hs | 13 + .../src/Language/Haskell/LSP/Types/Symbol.hs | 16 + .../Haskell/LSP/Types/TextDocument.hs | 24 + .../src/Language/Haskell/LSP/Types/Utils.hs | 127 +- .../src/Language/Haskell/LSP/Types/Window.hs | 295 ---- 28 files changed, 2357 insertions(+), 1673 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs diff --git a/.gitignore b/.gitignore index 6b12656c7..99b15dcfc 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,4 @@ stack*.yaml.lock /haskell-lsp-types/TAGS /haskell-lsp-types/tags /haskell-lsp-types/ctags +.hie diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index aa4c544ef..39867472d 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -25,21 +25,30 @@ library , Data.IxMap other-modules: Language.Haskell.LSP.Types.ClientCapabilities , Language.Haskell.LSP.Types.CodeAction + , Language.Haskell.LSP.Types.CodeLens , Language.Haskell.LSP.Types.Color , Language.Haskell.LSP.Types.Command , Language.Haskell.LSP.Types.Completion , Language.Haskell.LSP.Types.DataTypesJSON , Language.Haskell.LSP.Types.Diagnostic , Language.Haskell.LSP.Types.DocumentFilter + , Language.Haskell.LSP.Types.DocumentHighlight , Language.Haskell.LSP.Types.FoldingRange + , Language.Haskell.LSP.Types.Formatting , Language.Haskell.LSP.Types.Hover , Language.Haskell.LSP.Types.List , Language.Haskell.LSP.Types.Location , Language.Haskell.LSP.Types.LspId + , Language.Haskell.LSP.Types.Empty , Language.Haskell.LSP.Types.MarkupContent , Language.Haskell.LSP.Types.Method , Language.Haskell.LSP.Types.Message , Language.Haskell.LSP.Types.Progress + , Language.Haskell.LSP.Types.Registration + , Language.Haskell.LSP.Types.References + , Language.Haskell.LSP.Types.Rename + , Language.Haskell.LSP.Types.ServerCapabilities + , Language.Haskell.LSP.Types.StaticRegistrationOptions , Language.Haskell.LSP.Types.Symbol , Language.Haskell.LSP.Types.Synonyms , Language.Haskell.LSP.Types.TextDocument diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 7e36ab736..d5e59de40 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -6,6 +6,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Completion , module Language.Haskell.LSP.Types.Diagnostic , module Language.Haskell.LSP.Types.DocumentFilter + , module Language.Haskell.LSP.Types.Empty , module Language.Haskell.LSP.Types.FoldingRange , module Language.Haskell.LSP.Types.Hover , module Language.Haskell.LSP.Types.List @@ -32,6 +33,7 @@ import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter +import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.List diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 27afb2231..fc282bc14 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -152,10 +152,10 @@ data SymbolKindClientCapabilities = -- property exists the client also guarantees that it will -- handle values outside its set gracefully and falls back -- to a default value when unknown. - -- + -- -- If this property is not present the client only supports -- the symbol kinds from `File` to `Array` as defined in - -- the initial version of the protocol. + -- the initial version of the protocol. _valueSet :: Maybe (List SymbolKind) } deriving (Show, Read, Eq) @@ -583,10 +583,10 @@ export interface TextDocumentClientCapabilities { */ relatedInformation?: boolean; }; - + /** * Capabilities specific to `textDocument/foldingRange` requests. - * + * * Since 3.10.0 */ foldingRange?: { @@ -713,7 +713,7 @@ $(deriveJSON lspOptions ''HoverClientCapabilities) -- ------------------------------------- -data SignatureInformationClientCapabilities = +data SignatureInformationClientCapabilities = SignatureInformationClientCapabilities { -- | Client supports the follow content formats for the documentation -- property. The order describes the preferred format of the client. @@ -727,7 +727,7 @@ data SignatureHelpClientCapabilities = SignatureHelpClientCapabilities { -- | Whether signature help supports dynamic registration. _dynamicRegistration :: Maybe Bool - + -- | The client supports the following `SignatureInformation` -- specific properties. , _signatureInformation :: Maybe SignatureInformationClientCapabilities @@ -761,7 +761,7 @@ data DocumentSymbolKindClientCapabilities = -- property exists the client also guarantees that it will -- handle values outside its set gracefully and falls back -- to a default value when unknown. - -- + -- -- If this property is not present the client only supports -- the symbol kinds from `File` to `Array` as defined in -- the initial version of the protocol. @@ -1043,7 +1043,7 @@ instance Default TextDocumentClientCapabilities where -- --------------------------------------------------------------------- -- | Window specific client capabilities. -data WindowClientCapabilities = +data WindowClientCapabilities = WindowClientCapabilities { -- | Whether client supports handling progress notifications. _workDoneProgress :: Maybe Bool diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs index 9b6a736b0..971801d81 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs @@ -14,6 +14,7 @@ import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.WorkspaceEdit @@ -288,3 +289,38 @@ instance FromJSON CAResult where instance ToJSON CAResult where toJSON (CACommand x) = toJSON x toJSON (CACodeAction x) = toJSON x + + +-- --------------------------------------------------------------------- +{- +/** + * Code Action options. + */ +export interface CodeActionOptions { + /** + * CodeActionKinds that this server may return. + * + * The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server + * may list out every specific kind they provide. + */ + codeActionKinds?: CodeActionKind[]; +} +-} + +data CodeActionOptions = + CodeActionOptionsStatic Bool + | CodeActionOptions + { _codeActionKinds :: Maybe [CodeActionKind] + } deriving (Read,Show,Eq) + +deriveJSON (lspOptions { sumEncoding = UntaggedValue }) ''CodeActionOptions + +data CodeActionRegistrationOptions = + CodeActionRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _codeActionOptions :: CodeActionOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''CodeActionRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_codeActionOptions" + ] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs new file mode 100644 index 000000000..661448bea --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.LSP.Types.CodeLens where + +import Data.Aeson +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Command +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +{- + +The code lens request is sent from the client to the server to compute code lenses for a given text document. + +Client Capability: + +property name (optional): textDocument.codeLens +property type: CodeLensClientCapabilities defined as follows: +export interface CodeLensClientCapabilities { + /** + * Whether code lens supports dynamic registration. + */ + dynamicRegistration?: boolean; +} +Server Capability: + +property name (optional): codeLensProvider +property type: CodeLensOptions defined as follows: +export interface CodeLensOptions extends WorkDoneProgressOptions { + /** + * Code lens has a resolve provider as well. + */ + resolveProvider?: boolean; +} +Registration Options: CodeLensRegistrationOptions defined as follows: + +export interface CodeLensRegistrationOptions extends TextDocumentRegistrationOptions, CodeLensOptions { +} +Request: + +method: ‘textDocument/codeLens’ +params: CodeLensParams defined as follows: +interface CodeLensParams extends WorkDoneProgressParams, PartialResultParams { + /** + * The document to request code lens for. + */ + textDocument: TextDocumentIdentifier; +} +Response: + +result: CodeLens[] | null defined as follows: +/** + * A code lens represents a command that should be shown along with + * source text, like the number of references, a way to run tests, etc. + * + * A code lens is _unresolved_ when no command is associated to it. For performance + * reasons the creation of a code lens and resolving should be done in two stages. + */ +interface CodeLens { + /** + * The range in which this code lens is valid. Should only span a single line. + */ + range: Range; + + /** + * The command this code lens represents. + */ + command?: Command; + + /** + * A data entry field that is preserved on a code lens item between + * a code lens and a code lens resolve request. + */ + data?: any +} +partial result: CodeLens[] +error: code and message set in case an exception happens during the code lens request. + +-} + +data CodeLensParams = + CodeLensParams + { _textDocument :: TextDocumentIdentifier + , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''CodeLensParams + + +-- --------------------------------------------------------------------- + + +data CodeLens = + CodeLens + { _range :: Range + , _command :: Maybe Command + , _xdata :: Maybe Value + } deriving (Read,Show,Eq) + +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens + + +-- --------------------------------------------------------------------- +{- +/** + * Code Lens options. + */ +export interface CodeLensOptions extends WorkDoneProgressOptions { + /** + * Code lens has a resolve provider as well. + */ + resolveProvider?: boolean; +} +-} + +data CodeLensOptions = + CodeLensOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + -- | Code lens has a resolve provider as well. + , _resolveProvider :: Maybe Bool + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''CodeLensOptions [ "_workDoneProgressOptions" ] + +{- +Registration Options: CodeLensRegistrationOptions defined as follows: + +export interface CodeLensRegistrationOptions extends TextDocumentRegistrationOptions, CodeLensOptions { +} +-} + +data CodeLensRegistrationOptions = + CodeLensRegistrationOptions + { _documentSelector :: TextDocumentRegistrationOptions + , _codeLensOptions :: CodeLensOptions + } deriving (Show, Read, Eq) + +deriveJSONExtendFields lspOptions ''CodeLensRegistrationOptions + [ "_documentSelector" + , "_codeLensOptions" + ] + +-- --------------------------------------------------------------------- +{- +Code Lens Resolve Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#code-lens-resolve-request + +The code lens resolve request is sent from the client to the server to resolve +the command for a given code lens item. + +Request + + method: 'codeLens/resolve' + params: CodeLens + +Response + + result: CodeLens + error: code and message set in case an exception happens during the code + lens resolve request. + + +-} diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs index f83cd2ef2..887b09bc5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs @@ -8,8 +8,10 @@ import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.WorkspaceEdit +import Language.Haskell.LSP.Types.Utils {- Document Color Request (:leftwards_arrow_with_hook:) @@ -157,7 +159,7 @@ interface ColorPresentation { */ additionalTextEdits?: TextEdit[]; } -error: code and message set in case an exception happens during the +error: code and message set in case an exception happens during the ‘textDocument/colorPresentation’ request -} @@ -193,3 +195,19 @@ data ColorPresentation = deriveJSON lspOptions ''ColorPresentation +data DocumentColorOptions = + DocumentColorOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentColorOptions ["_workDoneProgressOptions"] + +data DocumentColorRegistrationOptions = + DocumentColorRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _staticRegistrationOptions :: StaticRegistrationOptions + , _documentColorOptions :: DocumentColorOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentColorRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_staticRegistrationOptions" + , "_documentColorOptions"] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs index e06d8b0ea..dfb346a6a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs @@ -43,3 +43,26 @@ data Command = } deriving (Show, Read, Eq) deriveJSON lspOptions ''Command + +{- +New in 3.0 +----------- + +/** + * Execute command options. + */ +export interface ExecuteCommandOptions { + /** + * The commands to be executed on the server + */ + commands: string[] +} +-} + +data ExecuteCommandOptions = + ExecuteCommandOptions + { -- | The commands to be executed on the server + _commands :: List Text + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ExecuteCommandOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs index 78cf244ec..c3460cf7e 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs @@ -486,6 +486,54 @@ data CompletionRegistrationOptions = deriveJSON lspOptions ''CompletionRegistrationOptions +-- ------------------------------------- + +{- +/** + * Completion options. + */ +interface CompletionOptions { + /** + * The server provides support to resolve additional information for a completion item. + */ + resolveProvider?: boolean; + + /** + * The characters that trigger completion automatically. + */ + triggerCharacters?: string[]; + + /** + * The list of all possible characters that commit a completion. This field can be used + * if clients don't support individual commmit characters per completion item. See + * `ClientCapabilities.textDocument.completion.completionItem.commitCharactersSupport`. + * + * If a server provides both `allCommitCharacters` and commit characters on an individual + * completion item the once on the completion item win. + * + * @since 3.2.0 + */ + allCommitCharacters?: string[]; +} +-} + +data CompletionOptions = + CompletionOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + -- | The server provides support to resolve additional information for a completion item. + , _resolveProvider :: Maybe Bool + -- | The characters that trigger completion automatically. + , _triggerCharacters :: Maybe [String] + -- | The list of all possible characters that commit a completion. This field can be used + -- if clients don't support individual commmit characters per completion item. See + -- `_commitCharactersSupport`. + -- Since LSP 3.2.0 + -- @since 0.18.0.0 + , _allCommitCharacters :: Maybe [String] + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''CompletionOptions ["_workDoneProgressOptions"] + -- --------------------------------------------------------------------- {- Completion Item Resolve Request diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index 2386293d8..5b04c774f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -14,7 +14,6 @@ module Language.Haskell.LSP.Types.DataTypesJSON where -import Control.Applicative import qualified Data.Aeson as A import Data.Aeson.TH import Data.Aeson.Types @@ -23,18 +22,17 @@ import Data.Scientific (floatingOrInteger) import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.LSP.Types.ClientCapabilities -import Language.Haskell.LSP.Types.CodeAction -import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Diagnostic -import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders @@ -158,641 +156,13 @@ data InitializeError = deriveJSON lspOptions ''InitializeError --- --------------------------------------------------------------------- -{- -The server can signal the following capabilities: - -/** - * Defines how the host (editor) should sync document changes to the language server. - */ -enum TextDocumentSyncKind { - /** - * Documents should not be synced at all. - */ - None = 0, - /** - * Documents are synced by always sending the full content of the document. - */ - Full = 1, - /** - * Documents are synced by sending the full content on open. After that only incremental - * updates to the document are sent. - */ - Incremental = 2 -} --} - --- ^ Note: Omitting this parameter from the capabilities is effectively a fourth --- state, where DidSave events are generated without sending document contents. -data TextDocumentSyncKind = TdSyncNone - | TdSyncFull - | TdSyncIncremental - deriving (Read,Eq,Show) - -instance A.ToJSON TextDocumentSyncKind where - toJSON TdSyncNone = A.Number 0 - toJSON TdSyncFull = A.Number 1 - toJSON TdSyncIncremental = A.Number 2 - -instance A.FromJSON TextDocumentSyncKind where - parseJSON (A.Number 0) = pure TdSyncNone - parseJSON (A.Number 1) = pure TdSyncFull - parseJSON (A.Number 2) = pure TdSyncIncremental - parseJSON _ = mempty - --- --------------------------------------------------------------------- -{- -/** - * Completion options. - */ -interface CompletionOptions { - /** - * The server provides support to resolve additional information for a completion item. - */ - resolveProvider?: boolean; - - /** - * The characters that trigger completion automatically. - */ - triggerCharacters?: string[]; - - /** - * The list of all possible characters that commit a completion. This field can be used - * if clients don't support individual commmit characters per completion item. See - * `ClientCapabilities.textDocument.completion.completionItem.commitCharactersSupport`. - * - * If a server provides both `allCommitCharacters` and commit characters on an individual - * completion item the once on the completion item win. - * - * @since 3.2.0 - */ - allCommitCharacters?: string[]; -} --} - -data CompletionOptions = - CompletionOptions - { _resolveProvider :: Maybe Bool - -- | The characters that trigger completion automatically. - , _triggerCharacters :: Maybe [String] - -- | The list of all possible characters that commit a completion. This field can be used - -- if clients don't support individual commmit characters per completion item. See - -- `_commitCharactersSupport`. - -- Since LSP 3.2.0 - -- @since 0.18.0.0 - , _allCommitCharacters :: Maybe [String] - } deriving (Read,Show,Eq) - -deriveJSON lspOptions {omitNothingFields = True } ''CompletionOptions - --- --------------------------------------------------------------------- -{- -/** - * Signature help options. - */ -interface SignatureHelpOptions { - /** - * The characters that trigger signature help automatically. - */ - triggerCharacters?: string[]; - /** - * List of characters that re-trigger signature help. - * - * These trigger characters are only active when signature help is already showing. All trigger characters - * are also counted as re-trigger characters. - * - * @since 3.15.0 - */ --} - -data SignatureHelpOptions = - SignatureHelpOptions - { -- | The characters that trigger signature help automatically. - _triggerCharacters :: Maybe [String] - - -- | List of characters that re-trigger signature help. - -- These trigger characters are only active when signature help is already showing. All trigger characters - -- are also counted as re-trigger characters. - -- - -- Since LSP 3.15.0 - -- @since 0.18.0.0 - , _retriggerCharacters :: Maybe [String] - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''SignatureHelpOptions - --- --------------------------------------------------------------------- -{- -/** - * Code Lens options. - */ -interface CodeLensOptions { - /** - * Code lens has a resolve provider as well. - */ - resolveProvider?: boolean; -} --} - -data CodeLensOptions = - CodeLensOptions - { _resolveProvider :: Maybe Bool - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''CodeLensOptions - --- --------------------------------------------------------------------- -{- -/** - * Code Action options. - */ -export interface CodeActionOptions { - /** - * CodeActionKinds that this server may return. - * - * The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server - * may list out every specific kind they provide. - */ - codeActionKinds?: CodeActionKind[]; -} --} - -data CodeActionOptions = - CodeActionOptionsStatic Bool - | CodeActionOptions - { _codeActionKinds :: Maybe [CodeActionKind] - } deriving (Read,Show,Eq) - -deriveJSON (lspOptions { sumEncoding = A.UntaggedValue }) ''CodeActionOptions - --- --------------------------------------------------------------------- -{- -/** - * Format document on type options - */ -interface DocumentOnTypeFormattingOptions { - /** - * A character on which formatting should be triggered, like `}`. - */ - firstTriggerCharacter: string; - /** - * More trigger characters. - */ - moreTriggerCharacter?: string[] -} --} -data DocumentOnTypeFormattingOptions = - DocumentOnTypeFormattingOptions - { _firstTriggerCharacter :: Text - , _moreTriggerCharacter :: Maybe [Text] - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DocumentOnTypeFormattingOptions - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -/** - * Document link options - */ -export interface DocumentLinkOptions { - /** - * Document links have a resolve provider as well. - */ - resolveProvider?: boolean; -} --} - -data DocumentLinkOptions = - DocumentLinkOptions - { -- | Document links have a resolve provider as well. - _resolveProvider :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DocumentLinkOptions - --- --------------------------------------------------------------------- -{- -New in 3.12 ----------- - -/** - * Rename options - */ -export interface RenameOptions { - /** - * Renames should be checked and tested before being executed. - */ - prepareProvider?: boolean; -} --} - -data RenameOptions = - RenameOptionsStatic Bool - | RenameOptions - { -- | Renames should be checked and tested before being executed. - _prepareProvider :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''RenameOptions - --- --------------------------------------------------------------------- - -{- -New in 3.0 ------------ - -/** - * Execute command options. - */ -export interface ExecuteCommandOptions { - /** - * The commands to be executed on the server - */ - commands: string[] -} --} - -data ExecuteCommandOptions = - ExecuteCommandOptions - { -- | The commands to be executed on the server - _commands :: List Text - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ExecuteCommandOptions - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- -/** - * Save options. - */ -export interface SaveOptions { - /** - * The client is supposed to include the content on save. - */ - includeText?: boolean; -} --} -data SaveOptions = - SaveOptions - { -- |The client is supposed to include the content on save. - _includeText :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''SaveOptions - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -export interface TextDocumentSyncOptions { - /** - * Open and close notifications are sent to the server. - */ - openClose?: boolean; - /** - * Change notificatins are sent to the server. See TextDocumentSyncKind.None, TextDocumentSyncKind.Full - * and TextDocumentSyncKindIncremental. - */ - change?: number; - /** - * Will save notifications are sent to the server. - */ - willSave?: boolean; - /** - * Will save wait until requests are sent to the server. - */ - willSaveWaitUntil?: boolean; - /** - * Save notifications are sent to the server. - */ - save?: SaveOptions; -} --} - -data TextDocumentSyncOptions = - TextDocumentSyncOptions - { -- | Open and close notifications are sent to the server. - _openClose :: Maybe Bool - - -- | Change notificatins are sent to the server. See - -- TextDocumentSyncKind.None, TextDocumentSyncKind.Full and - -- TextDocumentSyncKindIncremental. - , _change :: Maybe TextDocumentSyncKind - - -- | Will save notifications are sent to the server. - , _willSave :: Maybe Bool - - -- | Will save wait until requests are sent to the server. - , _willSaveWaitUntil :: Maybe Bool - - -- | Save notifications are sent to the server. - , _save :: Maybe SaveOptions - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''TextDocumentSyncOptions - --- --------------------------------------------------------------------- -{- - -Extended in 3.0 ---------------- - -interface ServerCapabilities { - /** - * Defines how text documents are synced. Is either a detailed structure defining each notification or - * for backwards compatibility the TextDocumentSyncKind number. If omitted it defaults to `TextDocumentSyncKind.None`. - */ - textDocumentSync?: TextDocumentSyncOptions | number; - /** - * The server provides hover support. - */ - hoverProvider?: boolean; - /** - * The server provides completion support. - */ - completionProvider?: CompletionOptions; - /** - * The server provides signature help support. - */ - signatureHelpProvider?: SignatureHelpOptions; - /** - * The server provides goto definition support. - */ - definitionProvider?: boolean; - /** - * The server provides Goto Type Definition support. - * - * Since 3.6.0 - */ - typeDefinitionProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides Goto Implementation support. - * - * Since 3.6.0 - */ - implementationProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides find references support. - */ - referencesProvider?: boolean; - /** - * The server provides document highlight support. - */ - documentHighlightProvider?: boolean; - /** - * The server provides document symbol support. - */ - documentSymbolProvider?: boolean; - /** - * The server provides workspace symbol support. - */ - workspaceSymbolProvider?: boolean; - /** - * The server provides code actions. The `CodeActionOptions` return type is only - * valid if the client signals code action literal support via the property - * `textDocument.codeAction.codeActionLiteralSupport`. - */ - codeActionProvider?: boolean | CodeActionOptions; - /** - * The server provides code lens. - */ - codeLensProvider?: CodeLensOptions; - /** - * The server provides document formatting. - */ - documentFormattingProvider?: boolean; - /** - * The server provides document range formatting. - */ - documentRangeFormattingProvider?: boolean; - /** - * The server provides document formatting on typing. - */ - documentOnTypeFormattingProvider?: DocumentOnTypeFormattingOptions; - /** - * The server provides rename support. - */ - renameProvider?: boolean; - /** - * The server provides document link support. - */ - documentLinkProvider?: DocumentLinkOptions; - /** - * The server provides color provider support. - * - * Since 3.6.0 - */ - colorProvider?: boolean | ColorProviderOptions | (ColorProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides folding provider support. - * - * Since 3.10.0 - */ - foldingRangeProvider?: boolean | FoldingRangeProviderOptions | (FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides execute command support. - */ - executeCommandProvider?: ExecuteCommandOptions; - /** - * Workspace specific server capabilities - */ - workspace?: { - /** - * The server supports workspace folder. - * - * Since 3.6.0 - */ - workspaceFolders?: { - /** - * The server has support for workspace folders - */ - supported?: boolean; - /** - * Whether the server wants to receive workspace folder - * change notifications. - * - * If a strings is provided the string is treated as a ID - * under which the notification is registered on the client - * side. The ID can be used to unregister for these events - * using the `client/unregisterCapability` request. - */ - changeNotifications?: string | boolean; - } - } - /** - * Experimental server capabilities. - */ - experimental?: any; -} --} - --- | Wrapper for TextDocumentSyncKind fallback. -data TDS = TDSOptions TextDocumentSyncOptions - | TDSKind TextDocumentSyncKind - deriving (Show, Read, Eq) - -instance FromJSON TDS where - parseJSON x = TDSOptions <$> parseJSON x <|> TDSKind <$> parseJSON x - -instance ToJSON TDS where - toJSON (TDSOptions x) = toJSON x - toJSON (TDSKind x) = toJSON x - -data GotoOptions = GotoOptionsStatic Bool - | GotoOptionsDynamic - { -- | A document selector to identify the scope of the registration. If set to null - -- the document selector provided on the client side will be used. - _documentSelector :: Maybe DocumentSelector - -- | The id used to register the request. The id can be used to deregister - -- the request again. See also Registration#id. - , _id :: Maybe Text - } - deriving (Show, Read, Eq) - -deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''GotoOptions --- TODO: Figure out how to make Lens', not Traversal', for sum types ---makeFieldsNoPrefix ''GotoOptions - -data ColorOptions = ColorOptionsStatic Bool - | ColorOptionsDynamic - | ColorOptionsDynamicDocument - { -- | A document selector to identify the scope of the registration. If set to null - -- the document selector provided on the client side will be used. - _documentSelector :: Maybe DocumentSelector - -- | The id used to register the request. The id can be used to deregister - -- the request again. See also Registration#id. - , _id :: Maybe Text - } - deriving (Show, Read, Eq) - -deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''ColorOptions --- makeFieldsNoPrefix ''ColorOptions - -data FoldingRangeOptions = FoldingRangeOptionsStatic Bool - | FoldingRangeOptionsDynamic - | FoldingRangeOptionsDynamicDocument - { -- | A document selector to identify the scope of the registration. If set to null - -- the document selector provided on the client side will be used. - _documentSelector :: Maybe DocumentSelector - -- | The id used to register the request. The id can be used to deregister - -- the request again. See also Registration#id. - , _id :: Maybe Text - } - deriving (Show, Read, Eq) - -deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''FoldingRangeOptions --- makeFieldsNoPrefix ''FoldingRangeOptions - -data WorkspaceFolderChangeNotifications = WorkspaceFolderChangeNotificationsString Text - | WorkspaceFolderChangeNotificationsBool Bool - deriving (Show, Read, Eq) - -deriveJSON lspOptions{ sumEncoding = A.UntaggedValue } ''WorkspaceFolderChangeNotifications - -data WorkspaceFolderOptions = - WorkspaceFolderOptions - { -- | The server has support for workspace folders - _supported :: Maybe Bool - -- | Whether the server wants to receive workspace folder - -- change notifications. - -- If a strings is provided the string is treated as a ID - -- under which the notification is registered on the client - -- side. The ID can be used to unregister for these events - -- using the `client/unregisterCapability` request. - , _changeNotifications :: Maybe WorkspaceFolderChangeNotifications - } - deriving (Show, Read, Eq) - -deriveJSON lspOptions ''WorkspaceFolderOptions - -data WorkspaceOptions = - WorkspaceOptions - { -- | The server supports workspace folder. Since LSP 3.6 - -- - -- @since 0.7.0.0 - _workspaceFolders :: Maybe WorkspaceFolderOptions - } - deriving (Show, Read, Eq) - -deriveJSON lspOptions ''WorkspaceOptions - -data InitializeResponseCapabilitiesInner = - InitializeResponseCapabilitiesInner - { -- | Defines how text documents are synced. Is either a detailed structure - -- defining each notification or for backwards compatibility the - -- 'TextDocumentSyncKind' number. - -- If omitted it defaults to 'TdSyncNone'. - _textDocumentSync :: Maybe TDS - -- | The server provides hover support. - , _hoverProvider :: Maybe Bool - -- | The server provides completion support. - , _completionProvider :: Maybe CompletionOptions - -- | The server provides signature help support. - , _signatureHelpProvider :: Maybe SignatureHelpOptions - -- | The server provides goto definition support. - , _definitionProvider :: Maybe Bool - -- | The server provides Goto Type Definition support. Since LSP 3.6 - -- - -- @since 0.7.0.0 - , _typeDefinitionProvider :: Maybe GotoOptions - -- | The server provides Goto Implementation support. - -- Since LSP 3.6 - -- - -- @since 0.7.0.0 - , _implementationProvider :: Maybe GotoOptions - -- | The server provides find references support. - , _referencesProvider :: Maybe Bool - -- | The server provides document highlight support. - , _documentHighlightProvider :: Maybe Bool - -- | The server provides document symbol support. - , _documentSymbolProvider :: Maybe Bool - -- | The server provides workspace symbol support. - , _workspaceSymbolProvider :: Maybe Bool - -- | The server provides code actions. - , _codeActionProvider :: Maybe CodeActionOptions - -- | The server provides code lens. - , _codeLensProvider :: Maybe CodeLensOptions - -- | The server provides document formatting. - , _documentFormattingProvider :: Maybe Bool - -- | The server provides document range formatting. - , _documentRangeFormattingProvider :: Maybe Bool - -- | The server provides document formatting on typing. - , _documentOnTypeFormattingProvider :: Maybe DocumentOnTypeFormattingOptions - -- | The server provides rename support. - , _renameProvider :: Maybe RenameOptions - -- | The server provides document link support. - , _documentLinkProvider :: Maybe DocumentLinkOptions - -- | The server provides color provider support. Since LSP 3.6 - -- - -- @since 0.7.0.0 - , _colorProvider :: Maybe ColorOptions - -- | The server provides folding provider support. Since LSP 3.10 - -- - -- @since 0.7.0.0 - , _foldingRangeProvider :: Maybe FoldingRangeOptions - -- | The server provides execute command support. - , _executeCommandProvider :: Maybe ExecuteCommandOptions - -- | Workspace specific server capabilities - , _workspace :: Maybe WorkspaceOptions - -- | Experimental server capabilities. - , _experimental :: Maybe A.Value - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''InitializeResponseCapabilitiesInner - -- --------------------------------------------------------------------- -- | -- Information about the capabilities of a language server -- data InitializeResponseCapabilities = InitializeResponseCapabilities { - _capabilities :: InitializeResponseCapabilitiesInner + _capabilities :: ServerCapabilities } deriving (Show, Read, Eq) deriveJSON lspOptions ''InitializeResponseCapabilities @@ -920,115 +290,25 @@ Notification: params: 'any' -} - -- --------------------------------------------------------------------- {- New in 3.0 ---------- -Register Capability +Unregister Capability -The client/registerCapability request is sent from the server to the client to -register for a new capability on the client side. Not all clients need to -support dynamic capability registration. A client opts in via the -ClientCapabilities.dynamicRegistration property. +The client/unregisterCapability request is sent from the server to the client to +unregister a previously register capability. Request: - method: 'client/registerCapability' - params: RegistrationParams + method: 'client/unregisterCapability' + params: UnregistrationParams -Where RegistrationParams are defined as follows: +Where UnregistrationParams are defined as follows: /** - * General paramters to to regsiter for a capability. - */ -export interface Registration { - /** - * The id used to register the request. The id can be used to deregister - * the request again. - */ - id: string; - - /** - * The method / capability to register for. - */ - method: string; - - /** - * Options necessary for the registration. - */ - registerOptions?: any; -} - -export interface RegistrationParams { - registrations: Registration[]; -} --} - -data Registration = - Registration - { -- |The id used to register the request. The id can be used to deregister - -- the request again. - _id :: Text - - -- | The method / capability to register for. - , _method :: SomeClientMethod - - -- | Options necessary for the registration. - , _registerOptions :: Maybe A.Value - } deriving (Show, Eq) - -deriveJSON lspOptions ''Registration - -data RegistrationParams = - RegistrationParams - { _registrations :: List Registration - } deriving (Show, Eq) - -deriveJSON lspOptions ''RegistrationParams - --- ------------------------------------- - -{- -Since most of the registration options require to specify a document selector -there is a base interface that can be used. - -export interface TextDocumentRegistrationOptions { - /** - * A document selector to identify the scope of the registration. If set to null - * the document selector provided on the client side will be used. - */ - documentSelector: DocumentSelector | null; -} --} - -data TextDocumentRegistrationOptions = - TextDocumentRegistrationOptions - { _documentSelector :: Maybe DocumentSelector - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''TextDocumentRegistrationOptions - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -Unregister Capability - -The client/unregisterCapability request is sent from the server to the client to -unregister a previously register capability. - -Request: - - method: 'client/unregisterCapability' - params: UnregistrationParams - -Where UnregistrationParams are defined as follows: - -/** - * General parameters to unregister a capability. + * General parameters to unregister a capability. */ export interface Unregistration { /** @@ -1374,11 +654,13 @@ export interface TextDocumentChangeRegistrationOptions extends TextDocumentRegis data TextDocumentChangeRegistrationOptions = TextDocumentChangeRegistrationOptions - { _documentSelector :: Maybe DocumentSelector - , _syncKind :: TextDocumentSyncKind + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + -- | How documents are synced to the server. + -- See 'TdSyncFull' and 'TdSyncIncremental' + , _syncKind :: TextDocumentSyncKind } deriving (Show, Read, Eq) -deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions +deriveJSONExtendFields lspOptions ''TextDocumentChangeRegistrationOptions ["_textDocumentRegistrationOptions"] -- --------------------------------------------------------------------- {- @@ -1493,28 +775,69 @@ Registration Options: TextDocumentRegistrationOptions {- DidSaveTextDocument Notification -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#didsavetextdocument-notification +The document save notification is sent from the client to the server when the document was saved in the client. + +Client Capability: + +property name (optional): textDocument.synchronization.didSave +property type: boolean +The capability indicates that the client supports textDocument/didSave notifications. + +Server Capability: + +property name (optional): textDocumentSync.save +property type: boolean | SaveOptions where SaveOptions is defined as follows: +export interface SaveOptions { + /** + * The client is supposed to include the content on save. + */ + includeText?: boolean; +} +The capability indicates that the server is interested in textDocument/didSave notifications. - New: The document save notification is sent from the client to the server - when the document was saved in the client. +Registration Options: TextDocumentSaveRegistrationOptions defined as follows: - method: 'textDocument/didSave' - params: DidSaveTextDocumentParams defined as follows: +export interface TextDocumentSaveRegistrationOptions extends TextDocumentRegistrationOptions { + /** + * The client is supposed to include the content on save. + */ + includeText?: boolean; +} +Notification: +method: 'textDocument/didSave' +params: DidSaveTextDocumentParams defined as follows: interface DidSaveTextDocumentParams { - /** - * The document that was saved. - */ - textDocument: TextDocumentIdentifier; + /** + * The document that was saved. + */ + textDocument: TextDocumentIdentifier; + + /** + * Optional the content when saved. Depends on the includeText value + * when the save notification was requested. + */ + text?: string; } -} data DidSaveTextDocumentParams = DidSaveTextDocumentParams { _textDocument :: TextDocumentIdentifier + , _text :: Maybe Text } deriving (Read,Show,Eq) deriveJSON lspOptions ''DidSaveTextDocumentParams +data TextDocumentSaveRegistrationOptions = + TextDocumentSaveRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + -- The spec doesn't say it extends SaveOptions, but it's the same fields. + -- Looks like an oversight + , _saveOptions :: SaveOptions + } deriving (Show, Read, Eq) + +deriveJSONExtendFields lspOptions ''TextDocumentSaveRegistrationOptions ["_textDocumentRegistrationOptions", "_saveOptions"] + -- --------------------------------------------------------------------- {- DidCloseTextDocument Notification @@ -1807,11 +1130,11 @@ export interface SignatureHelpRegistrationOptions extends TextDocumentRegistrati data SignatureHelpRegistrationOptions = SignatureHelpRegistrationOptions - { _documentSelector :: Maybe DocumentSelector - , _triggerCharacters :: Maybe (List String) + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _signatureHelpOptions :: SignatureHelpOptions } deriving (Show, Read, Eq) -deriveJSON lspOptions ''SignatureHelpRegistrationOptions +deriveJSONExtendFields lspOptions ''SignatureHelpRegistrationOptions ["_textDocumentRegistrationOptions", "_signatureHelpOptions"] -- --------------------------------------------------------------------- {- @@ -1819,23 +1142,48 @@ Goto Definition Request https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#goto-definition-request -The goto definition request is sent from the client to the server to resolve the -definition location of a symbol at a given text document position. +The go to definition request is sent from the client to the server to resolve the definition location of a symbol at a given text document position. - Changed: In 2.0 the request uses TextDocumentPositionParams with proper - textDocument and position properties. In 1.0 the uri of the referenced text - document was inlined into the params object. +The result type LocationLink[] got introduced with version 3.14.0 and depends on the corresponding client capability textDocument.definition.linkSupport. -Request +Client Capability: - method: 'textDocument/definition' - params: TextDocumentPositionParams +property name (optional): textDocument.definition +property type: DefinitionClientCapabilities defined as follows: +export interface DefinitionClientCapabilities { + /** + * Whether definition supports dynamic registration. + */ + dynamicRegistration?: boolean; -Response: + /** + * The client supports additional metadata in the form of definition links. + * + * @since 3.14.0 + */ + linkSupport?: boolean; +} +Server Capability: - result: Location | Location[] - error: code and message set in case an exception happens during the definition request. +property name (optional): definitionProvider +property type: boolean | DefinitionOptions where DefinitionOptions is defined as follows: +export interface DefinitionOptions extends WorkDoneProgressOptions { +} +Registration Options: DefinitionRegistrationOptions defined as follows: +export interface DefinitionRegistrationOptions extends TextDocumentRegistrationOptions, DefinitionOptions { +} +Request: + +method: ‘textDocument/definition’ +params: DefinitionParams defined as follows: +export interface DefinitionParams extends TextDocumentPositionParams, WorkDoneProgressParams, PartialResultParams { +} +Response: + +result: Location | Location[] | LocationLink[] | null +partial result: Location[] | LocationLink[] +error: code and message set in case an exception happens during the definition request. -} @@ -1852,195 +1200,6 @@ instance A.FromJSON LocationResponseParams where parseJSON xs@(A.Array _) = MultiLoc <$> parseJSON xs parseJSON x = SingleLoc <$> parseJSON x --- --------------------------------------------------------------------- - -{- -Goto Type Definition Request (:leftwards_arrow_with_hook:) -Since version 3.6.0 - -The goto type definition request is sent from the client to the server to resolve the type definition location of a symbol at a given text document position. - -Request: - -method: ‘textDocument/typeDefinition’ -params: TextDocumentPositionParams -Response: - -result: Location | Location[] | null -error: code and message set in case an exception happens during the definition request. -Registration Options: TextDocumentRegistrationOptions --} - --- --------------------------------------------------------------------- - -{- -Goto Implementation Request (:leftwards_arrow_with_hook:) -Since version 3.6.0 - -The goto implementation request is sent from the client to the server to resolve the implementation location of a symbol at a given text document position. - -Request: - -method: ‘textDocument/implementation’ -params: TextDocumentPositionParams -Response: - -result: Location | Location[] | null -error: code and message set in case an exception happens during the definition request. -Registration Options: TextDocumentRegistrationOptions --} - --- --------------------------------------------------------------------- - -{- -Find References Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#find-references-request - -The references request is sent from the client to the server to resolve -project-wide references for the symbol denoted by the given text document -position. - - Changed: In 2.0 the request uses TextDocumentPositionParams with proper - textDocument and position properties. In 1.0 the uri of the referenced text - document was inlined into the params object. - -Request - - method: 'textDocument/references' - params: ReferenceParams defined as follows: - -interface ReferenceParams extends TextDocumentPositionParams { - context: ReferenceContext -} - -interface ReferenceContext { - /** - * Include the declaration of the current symbol. - */ - includeDeclaration: boolean; -} - -Response: - - result: Location[] - error: code and message set in case an exception happens during the - reference request. --} - -data ReferenceContext = - ReferenceContext - { _includeDeclaration :: Bool - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''ReferenceContext - - -data ReferenceParams = - ReferenceParams - { _textDocument :: TextDocumentIdentifier - , _position :: Position - , _context :: ReferenceContext - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''ReferenceParams - --- --------------------------------------------------------------------- -{- -Document Highlights Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-highlights-request - -The document highlight request is sent from the client to the server to resolve -a document highlights for a given text document position. For programming -languages this usually highlights all references to the symbol scoped to this -file. However we kept 'textDocument/documentHighlight' and -'textDocument/references' separate requests since the first one is allowed to be -more fuzzy. Symbol matches usually have a DocumentHighlightKind of Read or Write -whereas fuzzy or textual matches use Textas the kind. - - Changed: In 2.0 the request uses TextDocumentPositionParams with proper - textDocument and position properties. In 1.0 the uri of the referenced text - document was inlined into the params object. - -Request - - method: 'textDocument/documentHighlight' - params: TextDocumentPositionParams - -Response - - result: DocumentHighlight[] defined as follows: - -/** - * A document highlight is a range inside a text document which deserves - * special attention. Usually a document highlight is visualized by changing - * the background color of its range. - * - */ -interface DocumentHighlight { - /** - * The range this highlight applies to. - */ - range: Range; - - /** - * The highlight kind, default is DocumentHighlightKind.Text. - */ - kind?: number; -} - -/** - * A document highlight kind. - */ -enum DocumentHighlightKind { - /** - * A textual occurrance. - */ - Text = 1, - - /** - * Read-access of a symbol, like reading a variable. - */ - Read = 2, - - /** - * Write-access of a symbol, like writing to a variable. - */ - Write = 3 -} - - error: code and message set in case an exception happens during the document - highlight request. - -Registration Options: TextDocumentRegistrationOptions - --} - -data DocumentHighlightKind = HkText | HkRead | HkWrite - deriving (Read,Show,Eq) - -instance A.ToJSON DocumentHighlightKind where - toJSON HkText = A.Number 1 - toJSON HkRead = A.Number 2 - toJSON HkWrite = A.Number 3 - -instance A.FromJSON DocumentHighlightKind where - parseJSON (A.Number 1) = pure HkText - parseJSON (A.Number 2) = pure HkRead - parseJSON (A.Number 3) = pure HkWrite - parseJSON _ = mempty - --- ------------------------------------- - -data DocumentHighlight = - DocumentHighlight - { _range :: Range - , _kind :: Maybe DocumentHighlightKind - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DocumentHighlight -- --------------------------------------------------------------------- {- @@ -2081,122 +1240,6 @@ data WorkspaceSymbolParams = deriveJSON lspOptions ''WorkspaceSymbolParams --- --------------------------------------------------------------------- -{- -Code Lens Request - -The code lens request is sent from the client to the server to compute code -lenses for a given text document. - - Changed: In 2.0 the request uses CodeLensParams instead of a single uri. - -Request - - method: 'textDocument/codeLens' - params: CodeLensParams defined as follows: - -interface CodeLensParams { - /** - * The document to request code lens for. - */ - textDocument: TextDocumentIdentifier; -} - -Response - - result: CodeLens[] defined as follows: - -/** - * A code lens represents a command that should be shown along with - * source text, like the number of references, a way to run tests, etc. - * - * A code lens is _unresolved_ when no command is associated to it. For performance - * reasons the creation of a code lens and resolving should be done in two stages. - */ -interface CodeLens { - /** - * The range in which this code lens is valid. Should only span a single line. - */ - range: Range; - - /** - * The command this code lens represents. - */ - command?: Command; - - /** - * A data entry field that is preserved on a code lens item between - * a code lens and a code lens resolve request. - */ - data?: any -} - - error: code and message set in case an exception happens during the code - lens request. --} - -data CodeLensParams = - CodeLensParams - { _textDocument :: TextDocumentIdentifier - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''CodeLensParams - - --- ------------------------------------- - -data CodeLens = - CodeLens - { _range :: Range - , _command :: Maybe Command - , _xdata :: Maybe A.Value - } deriving (Read,Show,Eq) - -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens - --- ------------------------------------- -{- -Registration Options: CodeLensRegistrationOptions defined as follows: - -export interface CodeLensRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * Code lens has a resolve provider as well. - */ - resolveProvider?: boolean; -} --} - -data CodeLensRegistrationOptions = - CodeLensRegistrationOptions - { _documentSelector :: Maybe DocumentSelector - , _resolveProvider :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''CodeLensRegistrationOptions - --- --------------------------------------------------------------------- -{- -Code Lens Resolve Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#code-lens-resolve-request - -The code lens resolve request is sent from the client to the server to resolve -the command for a given code lens item. - -Request - - method: 'codeLens/resolve' - params: CodeLens - -Response - - result: CodeLens - error: code and message set in case an exception happens during the code - lens resolve request. - - --} -- --------------------------------------------------------------------- {- @@ -2286,299 +1329,6 @@ Response: error: code and message set in case an exception happens during the document link resolve request. -} --- --------------------------------------------------------------------- -{- -Document Formatting Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-formatting-request - -The document formatting request is sent from the server to the client to format -a whole document. - -Request - - method: 'textDocument/formatting' - params: DocumentFormattingParams defined as follows - -interface DocumentFormattingParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The format options. - */ - options: FormattingOptions; -} - -/** - * Value-object describing what options formatting should use. - */ -interface FormattingOptions { - /** - * Size of a tab in spaces. - */ - tabSize: number; - - /** - * Prefer spaces over tabs. - */ - insertSpaces: boolean; - - /** - * Signature for further properties. - */ - [key: string]: boolean | number | string; -} - -Response - - result: TextEdit[] describing the modification to the document to be - formatted. - error: code and message set in case an exception happens during the - formatting request. - -Registration Options: TextDocumentRegistrationOptions --} - -data FormattingOptions = - FormattingOptions - { _tabSize :: Int - , _insertSpaces :: Bool -- ^ Prefer spaces over tabs - -- Note: May be more properties - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''FormattingOptions - -data DocumentFormattingParams = - DocumentFormattingParams - { _textDocument :: TextDocumentIdentifier - , _options :: FormattingOptions - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Show,Read,Eq) - -deriveJSON lspOptions ''DocumentFormattingParams --- --------------------------------------------------------------------- -{- -Document Range Formatting Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-range-formatting-request - -The document range formatting request is sent from the client to the server to -format a given range in a document. - -Request - - method: 'textDocument/rangeFormatting', - params: DocumentRangeFormattingParams defined as follows - -interface DocumentRangeFormattingParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The range to format - */ - range: Range; - - /** - * The format options - */ - options: FormattingOptions; -} - -Response - - result: TextEdit[] describing the modification to the document to be - formatted. - error: code and message set in case an exception happens during the range - formatting request. --} - -data DocumentRangeFormattingParams = - DocumentRangeFormattingParams - { _textDocument :: TextDocumentIdentifier - , _range :: Range - , _options :: FormattingOptions - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DocumentRangeFormattingParams - --- --------------------------------------------------------------------- -{- -Document on Type Formatting Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-on-type-formatting-request - -The document on type formatting request is sent from the client to the server to -format parts of the document during typing. - -Request - - method: 'textDocument/onTypeFormatting' - params: DocumentOnTypeFormattingParams defined as follows - -interface DocumentOnTypeFormattingParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The position at which this request was sent. - */ - position: Position; - - /** - * The character that has been typed. - */ - ch: string; - - /** - * The format options. - */ - options: FormattingOptions; -} - -Response - - result: TextEdit[] describing the modification to the document. - error: code and message set in case an exception happens during the range - formatting request. - -Registration Options: DocumentOnTypeFormattingRegistrationOptions defined as follows: - -export interface DocumentOnTypeFormattingRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * A character on which formatting should be triggered, like `}`. - */ - firstTriggerCharacter: string; - /** - * More trigger characters. - */ - moreTriggerCharacter?: string[] -} --} - -data DocumentOnTypeFormattingParams = - DocumentOnTypeFormattingParams - { _textDocument :: TextDocumentIdentifier - , _position :: Position - , _ch :: Text - , _options :: FormattingOptions - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DocumentOnTypeFormattingParams - -data DocumentOnTypeFormattingRegistrationOptions = - DocumentOnTypeFormattingRegistrationOptions - { _firstTriggerCharacter :: Text - , _moreTriggerCharacter :: Maybe (List String) - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DocumentOnTypeFormattingRegistrationOptions - --- --------------------------------------------------------------------- -{- -Rename Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#rename-request - -The rename request is sent from the client to the server to perform a -workspace-wide rename of a symbol. - -Request - - method: 'textDocument/rename' - params: RenameParams defined as follows - -interface RenameParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The position at which this request was sent. - */ - position: Position; - - /** - * The new name of the symbol. If the given name is not valid the - * request must return a [ResponseError](#ResponseError) with an - * appropriate message set. - */ - newName: string; -} - -Response - - result: WorkspaceEdit describing the modification to the workspace. - error: code and message set in case an exception happens during the rename - request. - -Registration Options: TextDocumentRegistrationOptions - --} -data RenameParams = - RenameParams - { _textDocument :: TextDocumentIdentifier - , _position :: Position - , _newName :: Text - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''RenameParams - - --- {\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"textDocument/rename\",\"params\":{\"textDocument\":{\"uri\":\"file:///home/alanz/mysrc/github/alanz/haskell-lsp/src/HieVscode.hs\"},\"position\":{\"line\":37,\"character\":17},\"newName\":\"getArgs'\"}} - --- --------------------------------------------------------------------- -{- -Prepare Rename Request - -Since version 3.12.0 - -The prepare rename request is sent from the client to the server to setup -and test the validity of a rename operation at a given location. - -Request: - - method: ‘textDocument/prepareRename’ - params: TextDocumentPositionParams - -Response: - - result: Range | { range: Range, placeholder: string } | null describing - the range of the string to rename and optionally a placeholder - text of the string content to be renamed. If null is returned - then it is deemed that a ‘textDocument/rename’ request is not - valid at the given position. - error: code and message set in case an exception happens during the - prepare rename request. - --} - --- {\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"textDocument/rename\",\"params\":{\"textDocument\":{\"uri\":\"file:///home/alanz/mysrc/github/alanz/haskell-lsp/src/HieVscode.hs\"},\"position\":{\"line\":37,\"character\":17},\"newName\":\"getArgs'\"}} - -data RangeWithPlaceholder = - RangeWithPlaceholder - { - _range :: Range - , _placeholder :: Text - } deriving Eq - -deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''RangeWithPlaceholder - -data RangeOrRangeWithPlaceholder = RangeWithPlaceholderValue RangeWithPlaceholder - | RangeValue Range - deriving Eq - -deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''RangeOrRangeWithPlaceholder -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs new file mode 100644 index 000000000..8759bb79b --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.Haskell.LSP.Types.DocumentHighlight where + +import Data.Aeson +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Utils + +-- --------------------------------------------------------------------- +{- +Document Highlights Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-highlights-request + +The document highlight request is sent from the client to the server to resolve +a document highlights for a given text document position. For programming +languages this usually highlights all references to the symbol scoped to this +file. However we kept 'textDocument/documentHighlight' and +'textDocument/references' separate requests since the first one is allowed to be +more fuzzy. Symbol matches usually have a DocumentHighlightKind of Read or Write +whereas fuzzy or textual matches use Textas the kind. + + Changed: In 2.0 the request uses TextDocumentPositionParams with proper + textDocument and position properties. In 1.0 the uri of the referenced text + document was inlined into the params object. + +Request + + method: 'textDocument/documentHighlight' + params: TextDocumentPositionParams + +Response + + result: DocumentHighlight[] defined as follows: + +/** + * A document highlight is a range inside a text document which deserves + * special attention. Usually a document highlight is visualized by changing + * the background color of its range. + * + */ +interface DocumentHighlight { + /** + * The range this highlight applies to. + */ + range: Range; + + /** + * The highlight kind, default is DocumentHighlightKind.Text. + */ + kind?: number; +} + +/** + * A document highlight kind. + */ +enum DocumentHighlightKind { + /** + * A textual occurrance. + */ + Text = 1, + + /** + * Read-access of a symbol, like reading a variable. + */ + Read = 2, + + /** + * Write-access of a symbol, like writing to a variable. + */ + Write = 3 +} + + error: code and message set in case an exception happens during the document + highlight request. + +Registration Options: TextDocumentRegistrationOptions + +-} + +data DocumentHighlightKind = HkText | HkRead | HkWrite + deriving (Read,Show,Eq) + +instance ToJSON DocumentHighlightKind where + toJSON HkText = Number 1 + toJSON HkRead = Number 2 + toJSON HkWrite = Number 3 + +instance FromJSON DocumentHighlightKind where + parseJSON (Number 1) = pure HkText + parseJSON (Number 2) = pure HkRead + parseJSON (Number 3) = pure HkWrite + parseJSON _ = mempty + +-- ------------------------------------- + +data DocumentHighlight = + DocumentHighlight + { _range :: Range + , _kind :: Maybe DocumentHighlightKind + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''DocumentHighlight + +data DocumentHighlightOptions = + DocumentHighlightOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''DocumentHighlightOptions ["_workDoneProgressOptions"] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs new file mode 100644 index 000000000..f24b54a85 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs @@ -0,0 +1,10 @@ +module Language.Haskell.LSP.Types.Empty where + +import Data.Aeson + +data Empty = Empty deriving (Eq,Ord,Show) +instance ToJSON Empty where + toJSON Empty = Null +instance FromJSON Empty where + parseJSON Null = pure Empty + parseJSON _ = mempty diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs index d25529514..22a31a7c5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs @@ -7,7 +7,9 @@ import Data.Aeson.TH import Data.Text (Text) import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils data FoldingRangeParams = FoldingRangeParams @@ -65,3 +67,21 @@ data FoldingRange = deriving (Read, Show, Eq) deriveJSON lspOptions ''FoldingRange + +data FoldingRangeOptions = + FoldingRangeOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''FoldingRangeOptions ["_workDoneProgressOptions"] + +data FoldingRangeRegistrationOptions = + FoldingRangeRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _foldingRangeOptions :: FoldingRangeOptions + , _staticRegistrationOptions :: StaticRegistrationOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''FoldingRangeRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_foldingRangeOptions" + , "_staticRegistrationOptions" + ] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs new file mode 100644 index 000000000..ff83d90ab --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +module Language.Haskell.LSP.Types.Formatting where + +import Data.Aeson.TH +import Data.Text (Text) +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +{- +Document Formatting Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-formatting-request + +The document formatting request is sent from the server to the client to format +a whole document. + +Request + + method: 'textDocument/formatting' + params: DocumentFormattingParams defined as follows + +interface DocumentFormattingParams { + /** + * The document to format. + */ + textDocument: TextDocumentIdentifier; + + /** + * The format options. + */ + options: FormattingOptions; +} + +/** + * Value-object describing what options formatting should use. + */ +interface FormattingOptions { + /** + * Size of a tab in spaces. + */ + tabSize: number; + + /** + * Prefer spaces over tabs. + */ + insertSpaces: boolean; + + /** + * Signature for further properties. + */ + [key: string]: boolean | number | string; +} + +Response + + result: TextEdit[] describing the modification to the document to be + formatted. + error: code and message set in case an exception happens during the + formatting request. + +Registration Options: TextDocumentRegistrationOptions +-} + +data FormattingOptions = + FormattingOptions + { _tabSize :: Int + , _insertSpaces :: Bool -- ^ Prefer spaces over tabs + -- Note: May be more properties + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''FormattingOptions + +data DocumentFormattingParams = + DocumentFormattingParams + { _textDocument :: TextDocumentIdentifier + , _options :: FormattingOptions + , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. + } deriving (Show,Read,Eq) + +deriveJSON lspOptions ''DocumentFormattingParams + +data DocumentFormattingOptions = + DocumentFormattingOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentFormattingOptions ["_workDoneProgressOptions"] + +data DocumentFormattingRegistrationOptions = + DocumentFormattingRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _documentFormattingOptions :: DocumentFormattingOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentFormattingRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_documentFormattingOptions" + ] + +-- --------------------------------------------------------------------- +{- +Document Range Formatting Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-range-formatting-request + +The document range formatting request is sent from the client to the server to +format a given range in a document. + +Request + + method: 'textDocument/rangeFormatting', + params: DocumentRangeFormattingParams defined as follows + +interface DocumentRangeFormattingParams { + /** + * The document to format. + */ + textDocument: TextDocumentIdentifier; + + /** + * The range to format + */ + range: Range; + + /** + * The format options + */ + options: FormattingOptions; +} + +Response + + result: TextEdit[] describing the modification to the document to be + formatted. + error: code and message set in case an exception happens during the range + formatting request. +-} + +data DocumentRangeFormattingParams = + DocumentRangeFormattingParams + { _textDocument :: TextDocumentIdentifier + , _range :: Range + , _options :: FormattingOptions + , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''DocumentRangeFormattingParams + +data DocumentRangeFormattingOptions = + DocumentRangeFormattingOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentRangeFormattingOptions ["_workDoneProgressOptions"] + +data DocumentRangeFormattingRegistrationOptions = + DocumentRangeFormattingRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _documentRangeFormattingOptions :: DocumentRangeFormattingOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentRangeFormattingRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_documentRangeFormattingOptions" + ] + +-- --------------------------------------------------------------------- +{- +Document on Type Formatting Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-on-type-formatting-request + +The document on type formatting request is sent from the client to the server to +format parts of the document during typing. + +Request + + method: 'textDocument/onTypeFormatting' + params: DocumentOnTypeFormattingParams defined as follows + +interface DocumentOnTypeFormattingParams { + /** + * The document to format. + */ + textDocument: TextDocumentIdentifier; + + /** + * The position at which this request was sent. + */ + position: Position; + + /** + * The character that has been typed. + */ + ch: string; + + /** + * The format options. + */ + options: FormattingOptions; +} + +Response + + result: TextEdit[] describing the modification to the document. + error: code and message set in case an exception happens during the range + formatting request. + +Registration Options: DocumentOnTypeFormattingRegistrationOptions defined as follows: + +export interface DocumentOnTypeFormattingRegistrationOptions extends TextDocumentRegistrationOptions { + /** + * A character on which formatting should be triggered, like `}`. + */ + firstTriggerCharacter: string; + /** + * More trigger characters. + */ + moreTriggerCharacter?: string[] +} +-} + +data DocumentOnTypeFormattingParams = + DocumentOnTypeFormattingParams + { _textDocument :: TextDocumentIdentifier + , _position :: Position + , _ch :: Text + , _options :: FormattingOptions + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''DocumentOnTypeFormattingParams + + +-- --------------------------------------------------------------------- +{- +/** + * Format document on type options + */ +interface DocumentOnTypeFormattingOptions { + /** + * A character on which formatting should be triggered, like `}`. + */ + firstTriggerCharacter: string; + /** + * More trigger characters. + */ + moreTriggerCharacter?: string[] +} +-} + +data DocumentOnTypeFormattingOptions = + DocumentOnTypeFormattingOptions + { -- | A character on which formatting should be triggered, like @}@. + _firstTriggerCharacter :: Text + , -- | More trigger characters. + _moreTriggerCharacter :: Maybe [Text] + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''DocumentOnTypeFormattingOptions + +data DocumentOnTypeFormattingRegistrationOptions = + DocumentOnTypeFormattingRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + -- This doesn't extend WorkDoneProgressOptions -- is this an oversight in the spec? + -- https://github.com/microsoft/language-server-protocol/issues/987 + , _documentOnTypeFormattingOptions :: DocumentOnTypeFormattingOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentOnTypeFormattingRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_documentOnTypeFormattingOptions" + ] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs index 52d2cb534..2a4349649 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs @@ -11,6 +11,9 @@ import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.MarkupContent +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- @@ -144,3 +147,18 @@ data Hover = } deriving (Read,Show,Eq) deriveJSON lspOptions ''Hover + +data HoverOptions = + HoverOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''HoverOptions ["_workDoneProgressOptions"] + +data HoverRegistrationOptions = + HoverRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _hoverOptions :: HoverOptions + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''HoverRegistrationOptions ["_textDocumentRegistrationOptions", "_hoverOptions"] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index e42f05ca4..eb34daad5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -10,15 +10,23 @@ module Language.Haskell.LSP.Types.Lens where import Language.Haskell.LSP.Types.ClientCapabilities import Language.Haskell.LSP.Types.CodeAction +import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter +import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Registration +import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Window @@ -77,9 +85,9 @@ makeFieldsNoPrefix ''DocumentLinkOptions makeFieldsNoPrefix ''ExecuteCommandOptions makeFieldsNoPrefix ''SaveOptions makeFieldsNoPrefix ''TextDocumentSyncOptions -makeFieldsNoPrefix ''WorkspaceFolderOptions -makeFieldsNoPrefix ''WorkspaceOptions -makeFieldsNoPrefix ''InitializeResponseCapabilitiesInner +makeFieldsNoPrefix ''WorkspaceServerCapabilities +makeFieldsNoPrefix ''WorkspaceFoldersServerCapabilities +makeFieldsNoPrefix ''ServerCapabilities makeFieldsNoPrefix ''InitializeResponseCapabilities makeFieldsNoPrefix ''Registration makeFieldsNoPrefix ''RegistrationParams @@ -98,12 +106,12 @@ makeFieldsNoPrefix ''DidChangeTextDocumentParams makeFieldsNoPrefix ''TextDocumentChangeRegistrationOptions makeFieldsNoPrefix ''WillSaveTextDocumentParams makeFieldsNoPrefix ''DidSaveTextDocumentParams +makeFieldsNoPrefix ''TextDocumentSaveRegistrationOptions makeFieldsNoPrefix ''DidCloseTextDocumentParams makeFieldsNoPrefix ''FileEvent makeFieldsNoPrefix ''DidChangeWatchedFilesParams makeFieldsNoPrefix ''PublishDiagnosticsParams makeFieldsNoPrefix ''LanguageString -makeFieldsNoPrefix ''Hover makeFieldsNoPrefix ''ParameterInformation makeFieldsNoPrefix ''SignatureInformation makeFieldsNoPrefix ''SignatureHelp @@ -181,6 +189,10 @@ makeFieldsNoPrefix ''Command makeFieldsNoPrefix ''Diagnostic makeFieldsNoPrefix ''DiagnosticRelatedInformation +-- Hover +makeFieldsNoPrefix ''Hover +makeFieldsNoPrefix ''HoverRegistrationOptions + -- Symbol makeFieldsNoPrefix ''DocumentSymbolParams makeFieldsNoPrefix ''DocumentSymbol diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index f4ef0ec79..c761e3760 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -20,15 +20,23 @@ module Language.Haskell.LSP.Types.Message where import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.CodeAction +import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.Method +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Registration +import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Window @@ -180,13 +188,6 @@ type family ResponseParams (m :: Method p Request) :: Type where -- Custom ResponseParams CustomMethod = Value -data Empty = Empty deriving (Eq,Ord,Show) -instance ToJSON Empty where - toJSON Empty = Null -instance FromJSON Empty where - parseJSON Null = pure Empty - parseJSON _ = mempty - -- --------------------------------------------------------------------- {- @@ -434,8 +435,6 @@ type family BaseHandlerFunc (t :: MethodType) (m :: Method p t) :: Type where -- Some helpful type synonyms type ClientMessage (m :: Method FromClient t) = Message m type ServerMessage (m :: Method FromServer t) = Message m -type SClientMethod (m :: Method FromClient t) = SMethod m -type SServerMethod (m :: Method FromServer t) = SMethod m -- --------------------------------------------------------------------- -- Working with arbritary messages diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index 83c4067fa..16eac787b 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -161,6 +161,10 @@ deriving instance Eq (SMethod m) deriving instance Ord (SMethod m) deriving instance Show (SMethod m) +-- Some useful type synonyms +type SClientMethod (m :: Method FromClient t) = SMethod m +type SServerMethod (m :: Method FromServer t) = SMethod m + data SomeClientMethod = forall t (m :: Method FromClient t). SomeClientMethod (SMethod m) data SomeServerMethod = forall t (m :: Method FromServer t). SomeServerMethod (SMethod m) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs index 433b114a9..5c581a300 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs @@ -1,7 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + module Language.Haskell.LSP.Types.Progress where +import Control.Applicative +import Control.Monad (unless) import qualified Data.Aeson as A -import Data.Text (Text) +import Data.Aeson.TH +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Language.Haskell.LSP.Types.Constants -- | A token used to report progress back or return partial results for a -- specific request. @@ -19,3 +30,315 @@ instance A.FromJSON ProgressToken where parseJSON (A.String t) = pure $ ProgressTextToken t parseJSON (A.Number i) = ProgressNumericToken <$> A.parseJSON (A.Number i) parseJSON v = fail $ "Invalid progress token: " ++ show v + +{- +Progress Begin Notification + +To start progress reporting a $/progress notification with the following payload must be sent: + +export interface WorkDoneProgressBegin { + + kind: 'begin'; + + /** + * Mandatory title of the progress operation. Used to briefly inform about + * the kind of operation being performed. + * + * Examples: "Indexing" or "Linking dependencies". + */ + title: string; + + /** + * Controls if a cancel button should show to allow the user to cancel the + * long running operation. Clients that don't support cancellation are allowed + * to ignore the setting. + */ + cancellable?: boolean; + + /** + * Optional, more detailed associated progress message. Contains + * complementary information to the `title`. + * + * Examples: "3/25 files", "project/src/module2", "node_modules/some_dep". + * If unset, the previous progress message (if any) is still valid. + */ + message?: string; + + /** + * Optional progress percentage to display (value 100 is considered 100%). + * If not provided infinite progress is assumed and clients are allowed + * to ignore the `percentage` value in subsequent in report notifications. + * + * The value should be steadily rising. Clients are free to ignore values + * that are not following this rule. + */ + percentage?: number; +-} + +-- | Parameters for a $/progress notification. +data ProgressParams t = + ProgressParams { + _token :: ProgressToken + , _value :: t + } deriving (Show, Read, Eq, Functor) + +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ProgressParams + +data SomeProgressParams + = Begin WorkDoneProgressBeginParams + | Report WorkDoneProgressReportParams + | End WorkDoneProgressEndParams + deriving Eq + +instance A.FromJSON SomeProgressParams where + parseJSON x = + (Begin <$> A.parseJSON x) + <|> (Report <$> A.parseJSON x) + <|> (End <$> A.parseJSON x) + +instance A.ToJSON SomeProgressParams where + toJSON (Begin x) = A.toJSON x + toJSON (Report x) = A.toJSON x + toJSON (End x) = A.toJSON x + +-- | Parameters for 'WorkDoneProgressBeginNotification'. +-- +-- @since 0.10.0.0 +data WorkDoneProgressBeginParams = + WorkDoneProgressBeginParams { + -- | Mandatory title of the progress operation. + -- Used to briefly inform about the kind of operation being + -- performed. Examples: "Indexing" or "Linking dependencies". + _title :: Text + -- | Controls if a cancel button should show to allow the user to cancel the + -- long running operation. Clients that don't support cancellation are allowed + -- to ignore the setting. + , _cancellable :: Maybe Bool + -- | Optional, more detailed associated progress + -- message. Contains complementary information to the + -- '_title'. Examples: "3/25 files", + -- "project/src/module2", "node_modules/some_dep". If + -- unset, the previous progress message (if any) is + -- still valid. + , _message :: Maybe Text + -- | Optional progress percentage to display (value 100 is considered 100%). + -- If not provided infinite progress is assumed and clients are allowed + -- to ignore the '_percentage' value in subsequent in report notifications. + -- + -- The value should be steadily rising. Clients are free to ignore values + -- that are not following this rule. + , _percentage :: Maybe Double + } deriving (Show, Read, Eq) + +instance A.ToJSON WorkDoneProgressBeginParams where + toJSON WorkDoneProgressBeginParams{..} = + A.object $ catMaybes + [ Just $ "kind" A..= ("begin" :: Text) + , Just $ "title" A..= _title + , ("cancellable" A..=) <$> _cancellable + , ("message" A..=) <$> _message + , ("percentage" A..=) <$> _percentage + ] + +instance A.FromJSON WorkDoneProgressBeginParams where + parseJSON = A.withObject "WorkDoneProgressBegin" $ \o -> do + kind <- o A..: "kind" + unless (kind == ("begin" :: Text)) $ fail $ "Expected kind \"begin\" but got " ++ show kind + _title <- o A..: "title" + _cancellable <- o A..:? "cancellable" + _message <- o A..:? "message" + _percentage <- o A..:? "percentage" + pure WorkDoneProgressBeginParams{..} + +-- | The $/progress begin notification is sent from the server to the +-- client to ask the client to start progress. +-- +-- @since 0.10.0.0 +{- +Progress Report Notification + +Reporting progress is done using the following payload: + +export interface WorkDoneProgressReport { + + kind: 'report'; + + /** + * Controls enablement state of a cancel button. This property is only valid if a cancel + * button got requested in the `WorkDoneProgressStart` payload. + * + * Clients that don't support cancellation or don't support control the button's + * enablement state are allowed to ignore the setting. + */ + cancellable?: boolean; + + /** + * Optional, more detailed associated progress message. Contains + * complementary information to the `title`. + * + * Examples: "3/25 files", "project/src/module2", "node_modules/some_dep". + * If unset, the previous progress message (if any) is still valid. + */ + message?: string; + + /** + * Optional progress percentage to display (value 100 is considered 100%). + * If not provided infinite progress is assumed and clients are allowed + * to ignore the `percentage` value in subsequent in report notifications. + * + * The value should be steadily rising. Clients are free to ignore values + * that are not following this rule. + */ + percentage?: number; +} +-} + +-- | Parameters for 'WorkDoneProgressReportNotification' +-- +-- @since 0.10.0.0 +data WorkDoneProgressReportParams = + WorkDoneProgressReportParams { + _cancellable :: Maybe Bool + -- | Optional, more detailed associated progress + -- message. Contains complementary information to the + -- '_title'. Examples: "3/25 files", + -- "project/src/module2", "node_modules/some_dep". If + -- unset, the previous progress message (if any) is + -- still valid. + , _message :: Maybe Text + -- | Optional progress percentage to display (value 100 is considered 100%). + -- If infinite progress was indicated in the start notification client + -- are allowed to ignore the value. In addition the value should be steadily + -- rising. Clients are free to ignore values that are not following this rule. + , _percentage :: Maybe Double + } deriving (Show, Read, Eq) + +instance A.ToJSON WorkDoneProgressReportParams where + toJSON WorkDoneProgressReportParams{..} = + A.object $ catMaybes + [ Just $ "kind" A..= ("report" :: Text) + , ("cancellable" A..=) <$> _cancellable + , ("message" A..=) <$> _message + , ("percentage" A..=) <$> _percentage + ] + +instance A.FromJSON WorkDoneProgressReportParams where + parseJSON = A.withObject "WorkDoneProgressReport" $ \o -> do + kind <- o A..: "kind" + unless (kind == ("report" :: Text)) $ fail $ "Expected kind \"report\" but got " ++ show kind + _cancellable <- o A..:? "cancellable" + _message <- o A..:? "message" + _percentage <- o A..:? "percentage" + pure WorkDoneProgressReportParams{..} + +-- | The workdone $/progress report notification is sent from the server to the +-- client to report progress for a previously started progress. +-- +-- @since 0.10.0.0 +{- +Progress End Notification + +Signaling the end of a progress reporting is done using the following payload: + +export interface WorkDoneProgressEnd { + + kind: 'end'; + + /** + * Optional, a final message indicating to for example indicate the outcome + * of the operation. + */ + message?: string; +} +-} + +-- | Parameters for 'WorkDoneProgressEndNotification'. +-- +-- @since 0.10.0.0 +data WorkDoneProgressEndParams = + WorkDoneProgressEndParams { + _message :: Maybe Text + } deriving (Show, Read, Eq) + +instance A.ToJSON WorkDoneProgressEndParams where + toJSON WorkDoneProgressEndParams{..} = + A.object $ catMaybes + [ Just $ "kind" A..= ("end" :: Text) + , ("message" A..=) <$> _message + ] + +instance A.FromJSON WorkDoneProgressEndParams where + parseJSON = A.withObject "WorkDoneProgressEnd" $ \o -> do + kind <- o A..: "kind" + unless (kind == ("end" :: Text)) $ fail $ "Expected kind \"end\" but got " ++ show kind + _message <- o A..:? "message" + pure WorkDoneProgressEndParams{..} + +-- | The $/progress end notification is sent from the server to the +-- client to stop a previously started progress. +-- +-- @since 0.10.0.0 +{- +Progress Cancel Notification + +The window/workDoneProgress/cancel notification is sent from the client to the server to inform the server that the user has pressed the cancel button on the progress UX. A server receiving a cancel request must still close a progress using the done notification. + +Notification: + +method: 'window/workDoneProgress/cancel' +params: WorkDoneProgressCancelParams defined as follows: +export interface WorkDoneProgressCancelParams { + /** + * The token to be used to report progress. + */ + token: ProgressToken; +} +-} + +-- | Parameters for 'WorkDoneProgressCancelNotification'. +-- +-- @since 0.10.0.0 +data WorkDoneProgressCancelParams = + WorkDoneProgressCancelParams { + -- | A unique identifier to associate multiple progress + -- notifications with the same progress. + _token :: ProgressToken + } deriving (Show, Read, Eq) + +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressCancelParams + +-- | The window/workDoneProgress/cancel notification is sent from the client to the server +-- to inform the server that the user has pressed the cancel button on the progress UX. +-- A server receiving a cancel request must still close a progress using the done notification. +-- +-- @since 0.10.0.0 + +data WorkDoneProgressCreateParams = + WorkDoneProgressCreateParams { + _token :: ProgressToken + } deriving (Show, Read, Eq) + +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressCreateParams + +data WorkDoneProgressOptions = + WorkDoneProgressOptions + { _workDoneProgress :: Maybe Bool + } + deriving (Read, Show, Eq) + +deriveJSON lspOptions ''WorkDoneProgressOptions + +data WorkDoneProgressParams = + WorkDoneProgressParams + { -- | An optional token that a server can use to report work done progress + _workDoneToken :: Maybe ProgressToken + } deriving (Read,Show,Eq) +deriveJSON lspOptions ''WorkDoneProgressParams + +data PartialResultParams = + PartialResultParams + { -- | An optional token that a server can use to report partial results + -- (e.g. streaming) to the client. + _partialResultToken :: Maybe ProgressToken + } deriving (Read,Show,Eq) +deriveJSON lspOptions ''PartialResultParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs new file mode 100644 index 000000000..eff146993 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.Haskell.LSP.Types.References where + +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Utils + +{- +Find References Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#find-references-request + +The references request is sent from the client to the server to resolve +project-wide references for the symbol denoted by the given text document +position. + + Changed: In 2.0 the request uses TextDocumentPositionParams with proper + textDocument and position properties. In 1.0 the uri of the referenced text + document was inlined into the params object. + +Request + + method: 'textDocument/references' + params: ReferenceParams defined as follows: + +interface ReferenceParams extends TextDocumentPositionParams { + context: ReferenceContext +} + +interface ReferenceContext { + /** + * Include the declaration of the current symbol. + */ + includeDeclaration: boolean; +} + +Response: + + result: Location[] + error: code and message set in case an exception happens during the + reference request. +-} + +data ReferenceContext = + ReferenceContext + { -- | Include the declaration of the current symbol. + _includeDeclaration :: Bool + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''ReferenceContext + + +data ReferenceParams = + ReferenceParams + { _textDocumentPositionParams :: TextDocumentPositionParams + , _workDoneProgressParams :: WorkDoneProgressParams + , _partialResultParams :: PartialResultParams + , _context :: ReferenceContext + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''ReferenceParams + [ "_textDocumentPositionParams" + , "_workDoneProgressParams" + , "_partialResultParams" + ] + +data ReferenceOptions = + ReferenceOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''ReferenceOptions ["_workDoneProgressOptions"] + +data ReferenceRegistrationOptions = + ReferenceRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _referenceOptions :: ReferenceOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''ReferenceRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_referenceOptions" + ] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs new file mode 100644 index 000000000..ca90886ab --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +module Language.Haskell.LSP.Types.Registration where + +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import Data.Function (on) +import Data.Kind +import Data.Void (Void) +import GHC.Generics +import Language.Haskell.LSP.Types.CodeAction +import Language.Haskell.LSP.Types.CodeLens +import Language.Haskell.LSP.Types.Color +import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.DataTypesJSON +import Language.Haskell.LSP.Types.ServerCapabilities +import Language.Haskell.LSP.Types.Empty +import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Formatting +import Language.Haskell.LSP.Types.Hover +import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Method +import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + + +-- --------------------------------------------------------------------- +{- +New in 3.0 +---------- + +Register Capability + +The client/registerCapability request is sent from the server to the client to +register for a new capability on the client side. Not all clients need to +support dynamic capability registration. A client opts in via the +ClientCapabilities.dynamicRegistration property. + +Request: + + method: 'client/registerCapability' + params: RegistrationParams + +Where RegistrationParams are defined as follows: + +/** + * General paramters to to regsiter for a capability. + */ +export interface Registration { + /** + * The id used to register the request. The id can be used to deregister + * the request again. + */ + id: string; + + /** + * The method / capability to register for. + */ + method: string; + + /** + * Options necessary for the registration. + */ + registerOptions?: any; +} + +export interface RegistrationParams { + registrations: Registration[]; +} +-} + + +type family RegistrationOptions (m :: Method FromClient t) :: Type where + -- Workspace + RegistrationOptions WorkspaceDidChangeWorkspaceFolders = Empty + RegistrationOptions WorkspaceDidChangeConfiguration = Empty + RegistrationOptions WorkspaceDidChangeWatchedFiles = DidChangeWatchedFilesRegistrationOptions + RegistrationOptions WorkspaceSymbol = Empty + RegistrationOptions WorkspaceExecuteCommand = ExecuteCommandRegistrationOptions + + -- Text synchronisation + RegistrationOptions TextDocumentDidOpen = TextDocumentRegistrationOptions + RegistrationOptions TextDocumentDidChange = TextDocumentChangeRegistrationOptions + RegistrationOptions TextDocumentWillSave = TextDocumentRegistrationOptions + RegistrationOptions TextDocumentWillSaveWaitUntil = TextDocumentRegistrationOptions + RegistrationOptions TextDocumentDidSave = TextDocumentSaveRegistrationOptions + RegistrationOptions TextDocumentDidClose = TextDocumentRegistrationOptions + + -- Language features + RegistrationOptions TextDocumentCompletion = CompletionRegistrationOptions + RegistrationOptions TextDocumentHover = HoverRegistrationOptions + RegistrationOptions TextDocumentSignatureHelp = SignatureHelpRegistrationOptions + -- TODO: Add me once textDocument/declaration is implemented + -- RegistrationOptions TextDocumentDeclaration = DeclarationRegistrationOptions + RegistrationOptions TextDocumentDefinition = DefinitionRegistrationOptions + RegistrationOptions TextDocumentTypeDefinition = TypeDefinitionRegistrationOptions + RegistrationOptions TextDocumentImplementation = ImplementationRegistrationOptions + RegistrationOptions TextDocumentReferences = ReferenceRegistrationOptions + -- TODO: Add me once textDocument/highlights is implemented + -- RegistrationOptions TextDocumentHighlights = DocumentHighlightRegistrationOptions + RegistrationOptions TextDocumentDocumentSymbol = DocumentSymbolRegistrationOptions + RegistrationOptions TextDocumentCodeAction = CodeActionRegistrationOptions + RegistrationOptions TextDocumentCodeLens = CodeLensRegistrationOptions + RegistrationOptions TextDocumentDocumentLink = DocumentLinkRegistrationOptions + RegistrationOptions TextDocumentDocumentColor = DocumentColorRegistrationOptions + RegistrationOptions TextDocumentFormatting = DocumentFormattingRegistrationOptions + RegistrationOptions TextDocumentRangeFormatting = DocumentRangeFormattingRegistrationOptions + RegistrationOptions TextDocumentOnTypeFormatting = DocumentOnTypeFormattingRegistrationOptions + RegistrationOptions TextDocumentRename = RenameRegistrationOptions + RegistrationOptions TextDocumentFoldingRange = FoldingRangeRegistrationOptions + -- TODO: Add me once textDocument/selectionRange is implemented + -- RegistrationOptions TextDocumentSelectionRange = SelectionRangeRegistrationOptions + RegistrationOptions m = Void + +data Registration (m :: Method FromClient t) = + Registration + { -- | The id used to register the request. The id can be used to deregister + -- the request again. + _id :: Text + -- | The method / capability to register for. + , _method :: SClientMethod m + -- | Options necessary for the registration. + -- Make this strict to aid the pattern matching exhaustiveness checker + , _registerOptions :: !(RegistrationOptions m) + } + deriving Generic + +deriving instance Eq (RegistrationOptions m) => Eq (Registration m) +deriving instance Show (RegistrationOptions m) => Show (Registration m) + +-- This generates the function +-- regHelper :: SMethod m +-- -> (( Show (RegistrationOptions m) +-- , ToJSON (RegistrationOptions m) +-- , FromJSON ($regOptTcon m) +-- => x) +-- -> x +makeRegHelper ''RegistrationOptions + +instance ToJSON (Registration m) where + toJSON x@(Registration _ m _) = regHelper m (genericToJSON lspOptions x) + +data SomeRegistration = forall t (m :: Method FromClient t). SomeRegistration (Registration m) + +instance ToJSON SomeRegistration where + toJSON (SomeRegistration r) = toJSON r + +instance FromJSON SomeRegistration where + parseJSON = withObject "Registration" $ \o -> do + SomeClientMethod m <- o .: "method" + r <- Registration <$> o .: "id" <*> pure m <*> regHelper m (o .: "registerOptions") + pure (SomeRegistration r) + +instance Eq SomeRegistration where + (==) = (==) `on` toJSON + +instance Show SomeRegistration where + show (SomeRegistration r@(Registration _ m _)) = regHelper m (show r) + +data RegistrationParams = + RegistrationParams { _registrations :: List SomeRegistration } + deriving (Show, Eq) + +deriveJSON lspOptions ''RegistrationParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs new file mode 100644 index 000000000..2a2943288 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Language.Haskell.LSP.Types.Rename where + +import Data.Aeson.TH +import Data.Text (Text) +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Utils + +-- --------------------------------------------------------------------- +{- +Rename Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#rename-request + +The rename request is sent from the client to the server to perform a +workspace-wide rename of a symbol. + +Request + + method: 'textDocument/rename' + params: RenameParams defined as follows + +interface RenameParams { + /** + * The document to format. + */ + textDocument: TextDocumentIdentifier; + + /** + * The position at which this request was sent. + */ + position: Position; + + /** + * The new name of the symbol. If the given name is not valid the + * request must return a [ResponseError](#ResponseError) with an + * appropriate message set. + */ + newName: string; +} + +Response + + result: WorkspaceEdit describing the modification to the workspace. + error: code and message set in case an exception happens during the rename + request. + +Registration Options: TextDocumentRegistrationOptions + +-} +data RenameParams = + RenameParams + { _textDocument :: TextDocumentIdentifier + , _position :: Position + , _newName :: Text + , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''RenameParams + + +-- {\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"textDocument/rename\",\"params\":{\"textDocument\":{\"uri\":\"file:///home/alanz/mysrc/github/alanz/haskell-lsp/src/HieVscode.hs\"},\"position\":{\"line\":37,\"character\":17},\"newName\":\"getArgs'\"}} + +-- --------------------------------------------------------------------- +{- +Prepare Rename Request + +Since version 3.12.0 + +The prepare rename request is sent from the client to the server to setup +and test the validity of a rename operation at a given location. + +Request: + + method: ‘textDocument/prepareRename’ + params: TextDocumentPositionParams + +Response: + + result: Range | { range: Range, placeholder: string } | null describing + the range of the string to rename and optionally a placeholder + text of the string content to be renamed. If null is returned + then it is deemed that a ‘textDocument/rename’ request is not + valid at the given position. + error: code and message set in case an exception happens during the + prepare rename request. + +-} + +-- {\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"textDocument/rename\",\"params\":{\"textDocument\":{\"uri\":\"file:///home/alanz/mysrc/github/alanz/haskell-lsp/src/HieVscode.hs\"},\"position\":{\"line\":37,\"character\":17},\"newName\":\"getArgs'\"}} + +data RangeWithPlaceholder = + RangeWithPlaceholder + { + _range :: Range + , _placeholder :: Text + } deriving Eq + +deriveJSON lspOptions { sumEncoding = UntaggedValue } ''RangeWithPlaceholder + +data RangeOrRangeWithPlaceholder = RangeWithPlaceholderValue RangeWithPlaceholder + | RangeValue Range + deriving Eq + +deriveJSON lspOptions { sumEncoding = UntaggedValue } ''RangeOrRangeWithPlaceholder + + +-- --------------------------------------------------------------------- +{- +New in 3.12 +---------- + +/** + * Rename options + */ +export interface RenameOptions { + /** + * Renames should be checked and tested before being executed. + */ + prepareProvider?: boolean; +} +-} + +data RenameOptions = + RenameOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + -- | Renames should be checked and tested before being executed. + , _prepareProvider :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSONExtendFields lspOptions ''RenameOptions ["_workDoneProgressOptions"] + +data RenameRegistrationOptions = + RenameRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _renameOptions :: RenameOptions + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''RenameRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_renameOptions" + ] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs new file mode 100644 index 000000000..c326904aa --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -0,0 +1,560 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Language.Haskell.LSP.Types.ServerCapabilities where + +import Control.Applicative +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import Language.Haskell.LSP.Types.CodeAction +import Language.Haskell.LSP.Types.CodeLens +import Language.Haskell.LSP.Types.Color +import Language.Haskell.LSP.Types.Command +import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Formatting +import Language.Haskell.LSP.Types.Hover +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.StaticRegistrationOptions +import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +data a |? b = L a + | R b + deriving (Read,Show,Eq) + +instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where + toJSON (L x) = toJSON x + toJSON (R x) = toJSON x + +instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where + parseJSON v = L <$> parseJSON v <|> R <$> parseJSON v + +-- --------------------------------------------------------------------- +{- +The server can signal the following capabilities: + +/** + * Defines how the host (editor) should sync document changes to the language server. + */ +enum TextDocumentSyncKind { + /** + * Documents should not be synced at all. + */ + None = 0, + /** + * Documents are synced by always sending the full content of the document. + */ + Full = 1, + /** + * Documents are synced by sending the full content on open. After that only incremental + * updates to the document are sent. + */ + Incremental = 2 +} +-} + +-- ^ Note: Omitting this parameter from the capabilities is effectively a fourth +-- state, where DidSave events are generated without sending document contents. +data TextDocumentSyncKind = TdSyncNone + | TdSyncFull + | TdSyncIncremental + deriving (Read,Eq,Show) + +instance ToJSON TextDocumentSyncKind where + toJSON TdSyncNone = Number 0 + toJSON TdSyncFull = Number 1 + toJSON TdSyncIncremental = Number 2 + +instance FromJSON TextDocumentSyncKind where + parseJSON (Number 0) = pure TdSyncNone + parseJSON (Number 1) = pure TdSyncFull + parseJSON (Number 2) = pure TdSyncIncremental + parseJSON _ = mempty + + +-- --------------------------------------------------------------------- +{- +New in 3.0 +---------- +/** + * Save options. + */ +export interface SaveOptions { + /** + * The client is supposed to include the content on save. + */ + includeText?: boolean; +} +-} +data SaveOptions = + SaveOptions + { -- | The client is supposed to include the content on save. + _includeText :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''SaveOptions + +-- --------------------------------------------------------------------- +{- +New in 3.0 +---------- + +export interface TextDocumentSyncOptions { + /** + * Open and close notifications are sent to the server. + */ + openClose?: boolean; + /** + * Change notificatins are sent to the server. See TextDocumentSyncKind.None, TextDocumentSyncKind.Full + * and TextDocumentSyncKindIncremental. + */ + change?: number; + /** + * Will save notifications are sent to the server. + */ + willSave?: boolean; + /** + * Will save wait until requests are sent to the server. + */ + willSaveWaitUntil?: boolean; + /** + * Save notifications are sent to the server. + */ + save?: SaveOptions; +} +-} + +data TextDocumentSyncOptions = + TextDocumentSyncOptions + { -- | Open and close notifications are sent to the server. + _openClose :: Maybe Bool + + -- | Change notificatins are sent to the server. See + -- TextDocumentSyncKind.None, TextDocumentSyncKind.Full and + -- TextDocumentSyncKindIncremental. + , _change :: Maybe TextDocumentSyncKind + + -- | Will save notifications are sent to the server. + , _willSave :: Maybe Bool + + -- | Will save wait until requests are sent to the server. + , _willSaveWaitUntil :: Maybe Bool + + -- | Save notifications are sent to the server. + , _save :: Maybe SaveOptions + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''TextDocumentSyncOptions + +-- --------------------------------------------------------------------- +{- + +Extended in 3.0 +--------------- + +interface ServerCapabilities { + /** + * Defines how text documents are synced. Is either a detailed structure defining each notification or + * for backwards compatibility the TextDocumentSyncKind number. If omitted it defaults to `TextDocumentSyncKind.None`. + */ + textDocumentSync?: TextDocumentSyncOptions | number; + /** + * The server provides hover support. + */ + hoverProvider?: boolean; + /** + * The server provides completion support. + */ + completionProvider?: CompletionOptions; + /** + * The server provides signature help support. + */ + signatureHelpProvider?: SignatureHelpOptions; + /** + * The server provides goto definition support. + */ + definitionProvider?: boolean; + /** + * The server provides Goto Type Definition support. + * + * Since 3.6.0 + */ + typeDefinitionProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); + /** + * The server provides Goto Implementation support. + * + * Since 3.6.0 + */ + implementationProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); + /** + * The server provides find references support. + */ + referencesProvider?: boolean; + /** + * The server provides document highlight support. + */ + documentHighlightProvider?: boolean; + /** + * The server provides document symbol support. + */ + documentSymbolProvider?: boolean; + /** + * The server provides workspace symbol support. + */ + workspaceSymbolProvider?: boolean; + /** + * The server provides code actions. The `CodeActionOptions` return type is only + * valid if the client signals code action literal support via the property + * `textDocument.codeAction.codeActionLiteralSupport`. + */ + codeActionProvider?: boolean | CodeActionOptions; + /** + * The server provides code lens. + */ + codeLensProvider?: CodeLensOptions; + /** + * The server provides document formatting. + */ + documentFormattingProvider?: boolean; + /** + * The server provides document range formatting. + */ + documentRangeFormattingProvider?: boolean; + /** + * The server provides document formatting on typing. + */ + documentOnTypeFormattingProvider?: DocumentOnTypeFormattingOptions; + /** + * The server provides rename support. + */ + renameProvider?: boolean; + /** + * The server provides document link support. + */ + documentLinkProvider?: DocumentLinkOptions; + /** + * The server provides color provider support. + * + * Since 3.6.0 + */ + colorProvider?: boolean | ColorProviderOptions | (ColorProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions); + /** + * The server provides folding provider support. + * + * Since 3.10.0 + */ + foldingRangeProvider?: boolean | FoldingRangeProviderOptions | (FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions); + /** + * The server provides execute command support. + */ + executeCommandProvider?: ExecuteCommandOptions; + /** + * Workspace specific server capabilities + */ + workspace?: { + /** + * The server supports workspace folder. + * + * Since 3.6.0 + */ + workspaceFolders?: { + /** + * The server has support for workspace folders + */ + supported?: boolean; + /** + * Whether the server wants to receive workspace folder + * change notifications. + * + * If a strings is provided the string is treated as a ID + * under which the notification is registered on the client + * side. The ID can be used to unregister for these events + * using the `client/unregisterCapability` request. + */ + changeNotifications?: string | boolean; + } + } + /** + * Experimental server capabilities. + */ + experimental?: any; +} +-} + +-- | Wrapper for TextDocumentSyncKind fallback. +data TDS = TDSOptions TextDocumentSyncOptions + | TDSKind TextDocumentSyncKind + deriving (Show, Read, Eq) + +instance FromJSON TDS where + parseJSON x = TDSOptions <$> parseJSON x <|> TDSKind <$> parseJSON x + +instance ToJSON TDS where + toJSON (TDSOptions x) = toJSON x + toJSON (TDSKind x) = toJSON x + +{- +/** + * Signature help options. + */ +interface SignatureHelpOptions { + /** + * The characters that trigger signature help automatically. + */ + triggerCharacters?: string[]; + /** + * List of characters that re-trigger signature help. + * + * These trigger characters are only active when signature help is already showing. All trigger characters + * are also counted as re-trigger characters. + * + * @since 3.15.0 + */ +-} + +data SignatureHelpOptions = + SignatureHelpOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + , -- | The characters that trigger signature help automatically. + _triggerCharacters :: Maybe [String] + + -- | List of characters that re-trigger signature help. + -- These trigger characters are only active when signature help is already showing. All trigger characters + -- are also counted as re-trigger characters. + -- + -- Since LSP 3.15.0 + -- @since 0.18.0.0 + , _retriggerCharacters :: Maybe [String] + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''SignatureHelpOptions ["_workDoneProgressOptions"] + +-- --------------------------------------------------------------------- + +data DefinitionOptions = + DefinitionOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } + deriving (Eq,Read,Show) + +deriveJSONExtendFields lspOptions ''DefinitionOptions ["_workDoneProgressOptions"] + +data DefinitionRegistrationOptions = + DefinitionRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _definitionOptions :: DefinitionOptions + } deriving (Read,Show,Eq) + +deriveJSONExtendFields lspOptions ''DefinitionRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_definitionOptions" + ] + + +-- --------------------------------------------------------------------- + +{- +Goto Type Definition Request (:leftwards_arrow_with_hook:) +Since version 3.6.0 + +The goto type definition request is sent from the client to the server to resolve the type definition location of a symbol at a given text document position. + +Request: + +method: ‘textDocument/typeDefinition’ +params: TextDocumentPositionParams +Response: + +result: Location | Location[] | null +error: code and message set in case an exception happens during the definition request. +Registration Options: TextDocumentRegistrationOptions +-} + +data TypeDefinitionOptions = + TypeDefinitionOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''TypeDefinitionOptions ["_workDoneProgressOptions"] + +data TypeDefinitionRegistrationOptions = + TypeDefinitionRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _typeDefinitionOptions :: TypeDefinitionOptions + , _staticRegistrationOptions :: StaticRegistrationOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''TypeDefinitionRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_typeDefinitionOptions" + , "_staticRegistrationOptions" + ] + + +-- --------------------------------------------------------------------- + +{- +Goto Implementation Request (:leftwards_arrow_with_hook:) +Since version 3.6.0 + +The goto implementation request is sent from the client to the server to resolve the implementation location of a symbol at a given text document position. + +Request: + +method: ‘textDocument/implementation’ +params: TextDocumentPositionParams +Response: + +result: Location | Location[] | null +error: code and message set in case an exception happens during the definition request. +Registration Options: TextDocumentRegistrationOptions +-} + +data ImplementationOptions = + ImplementationOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''ImplementationOptions ["_workDoneProgressOptions"] + +data ImplementationRegistrationOptions = + ImplementationRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _implementationOptions :: ImplementationOptions + , _staticRegistrationOptions :: StaticRegistrationOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''ImplementationRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_implementationOptions" + , "_staticRegistrationOptions" + ] + +-- --------------------------------------------------------------------- +{- +New in 3.0 +---------- + +/** + * Document link options + */ +export interface DocumentLinkOptions { + /** + * Document links have a resolve provider as well. + */ + resolveProvider?: boolean; +} +-} + +data DocumentLinkOptions = + DocumentLinkOptions + { -- | Document links have a resolve provider as well. + _resolveProvider :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DocumentLinkOptions + +data DocumentLinkRegistrationOptions = + DocumentLinkRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _documentLinkOptions :: DocumentLinkOptions + } deriving (Read,Show,Eq) +deriveJSONExtendFields lspOptions ''DocumentLinkRegistrationOptions + [ "_textDocumentRegistrationOptions" + , "_documentLinkOptions" + ] + +data WorkspaceFoldersServerCapabilities = + WorkspaceFoldersServerCapabilities + { -- | The server has support for workspace folders + _supported :: Maybe Bool + -- | Whether the server wants to receive workspace folder + -- change notifications. + -- If a strings is provided the string is treated as a ID + -- under which the notification is registered on the client + -- side. The ID can be used to unregister for these events + -- using the `client/unregisterCapability` request. + , _changeNotifications :: Maybe (Text |? Bool) + } + deriving (Show, Read, Eq) + +deriveJSON lspOptions ''WorkspaceFoldersServerCapabilities + +data WorkspaceServerCapabilities = + WorkspaceServerCapabilities + { -- | The server supports workspace folder. Since LSP 3.6 + -- Since LSP 3.6.0 + -- + -- @since 0.7.0.0 + _workspaceFolders :: Maybe WorkspaceFoldersServerCapabilities + } + deriving (Show, Read, Eq) +deriveJSON lspOptions ''WorkspaceServerCapabilities + +data ServerCapabilities = + ServerCapabilities + { -- | Defines how text documents are synced. Is either a detailed structure + -- defining each notification or for backwards compatibility the + -- 'TextDocumentSyncKind' number. + -- If omitted it defaults to 'TdSyncNone'. + _textDocumentSync :: Maybe TDS + -- | The server provides hover support. + , _hoverProvider :: Maybe (Bool |? HoverOptions) + -- | The server provides completion support. + , _completionProvider :: Maybe CompletionOptions + -- | The server provides signature help support. + , _signatureHelpProvider :: Maybe SignatureHelpOptions + -- | The server provides goto definition support. + , _definitionProvider :: Maybe (Bool |? DefinitionOptions) + -- | The server provides Goto Type Definition support. Since LSP 3.6 + -- + -- @since 0.7.0.0 + , _typeDefinitionProvider :: Maybe (Bool |? TypeDefinitionOptions |? TypeDefinitionRegistrationOptions) + -- | The server provides Goto Implementation support. + -- Since LSP 3.6 + -- + -- @since 0.7.0.0 + , _implementationProvider :: Maybe (Bool |? ImplementationOptions |? ImplementationRegistrationOptions) + -- | The server provides find references support. + , _referencesProvider :: Maybe (Bool |? ReferenceOptions) + -- | The server provides document highlight support. + , _documentHighlightProvider :: Maybe (Bool |? DocumentHighlightOptions) + -- | The server provides document symbol support. + , _documentSymbolProvider :: Maybe (Bool |? DocumentSymbolOptions) + -- | The server provides code actions. + , _codeActionProvider :: Maybe (Bool |? CodeActionOptions) + -- | The server provides code lens. + , _codeLensProvider :: Maybe CodeLensOptions + -- | The server provides document link support. + , _documentLinkProvider :: Maybe DocumentLinkOptions + -- | The server provides color provider support. Since LSP 3.6 + -- + -- @since 0.7.0.0 + , _colorProvider :: Maybe (Bool |? DocumentColorOptions |? DocumentColorRegistrationOptions) + -- | The server provides document formatting. + , _documentFormattingProvider :: Maybe (Bool |? DocumentFormattingOptions) + -- | The server provides document range formatting. + , _documentRangeFormattingProvider :: Maybe (Bool |? DocumentRangeFormattingOptions) + -- | The server provides document formatting on typing. + , _documentOnTypeFormattingProvider :: Maybe DocumentOnTypeFormattingOptions + -- | The server provides rename support. + , _renameProvider :: Maybe (Bool |? RenameOptions) + -- | The server provides folding provider support. Since LSP 3.10 + -- + -- @since 0.7.0.0 + , _foldingRangeProvider :: Maybe (Bool |? FoldingRangeOptions |? FoldingRangeRegistrationOptions) + -- | The server provides execute command support. + , _executeCommandProvider :: Maybe ExecuteCommandOptions + -- | The server provides workspace symbol support. + , _workspaceSymbolProvider :: Maybe Bool + -- | Workspace specific server capabilities + , _workspace :: Maybe WorkspaceServerCapabilities + -- | Experimental server capabilities. + , _experimental :: Maybe Value + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ServerCapabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs new file mode 100644 index 000000000..e44095ccc --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +-- Cyclic dependencies mean we have to put poor StaticRegistrationOptions on its own +module Language.Haskell.LSP.Types.StaticRegistrationOptions where + +import Data.Aeson.TH +import Data.Text (Text) +import Language.Haskell.LSP.Types.Constants + +data StaticRegistrationOptions = + StaticRegistrationOptions + { _id :: Maybe Text + } deriving (Read,Show,Eq) +deriveJSON lspOptions ''StaticRegistrationOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs index 8dbb72dc5..f53165067 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs @@ -12,6 +12,7 @@ import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- {- @@ -267,4 +268,19 @@ instance ToJSON DSResult where toJSON (DSDocumentSymbols x) = toJSON x toJSON (DSSymbolInformation x) = toJSON x +data DocumentSymbolOptions = + DocumentSymbolOptions + { _workDoneProgressOptions :: WorkDoneProgressOptions + } + deriving (Read, Show, Eq) +deriveJSONExtendFields lspOptions ''DocumentSymbolOptions ["_workDoneProgressOptions"] + +data DocumentSymbolRegistrationOptions = + DocumentSymbolRegistrationOptions + { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions + , _documentSymbolOptions :: DocumentSymbolOptions + } + deriving (Read, Show, Eq) + +deriveJSONExtendFields lspOptions ''DocumentSymbolRegistrationOptions ["_textDocumentRegistrationOptions", "_documentSymbolOptions"] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs index 53ba138fb..7ed0ddfb2 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs @@ -5,6 +5,7 @@ module Language.Haskell.LSP.Types.TextDocument where import Data.Aeson.TH import Data.Text ( Text ) import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Uri @@ -103,3 +104,26 @@ data TextDocumentPositionParams = } deriving (Show, Read, Eq) deriveJSON lspOptions ''TextDocumentPositionParams + + +-- ------------------------------------- + +{- +Since most of the registration options require to specify a document selector +there is a base interface that can be used. + +export interface TextDocumentRegistrationOptions { + /** + * A document selector to identify the scope of the registration. If set to null + * the document selector provided on the client side will be used. + */ + documentSelector: DocumentSelector | null; +} +-} + +data TextDocumentRegistrationOptions = + TextDocumentRegistrationOptions + { _documentSelector :: Maybe DocumentSelector + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''TextDocumentRegistrationOptions \ No newline at end of file diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs index 7a70bdb44..d6a32fb44 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs @@ -1,14 +1,19 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} module Language.Haskell.LSP.Types.Utils ( rdrop , makeSingletonFromJSON + , deriveJSONExtendFields + , makeRegHelper ) where +import qualified Data.HashMap.Strict as HM import Language.Haskell.TH import Data.Aeson +import Data.String import Control.Monad -import Data.List (foldl') +import Data.List (foldl', (\\)) -- --------------------------------------------------------------------- @@ -41,3 +46,123 @@ makeInst wrap (GadtC [sConstructor] args t) = do |] makeInst wrap (ForallC _ _ con) = makeInst wrap con -- Cancel and Custom requests makeInst _ _ = fail "makeInst only defined for GADT constructors" + +-- | Generate ToJSON/FromJSON instances where the specified fields are +-- encoded directly inside object, unwrapped, and not another layer. +-- Use this for encoding types that extend an interface in the typescript +-- specification. +-- The field names are passed as strings to work around duplicate record fields. +deriveJSONExtendFields :: Options -> Name -> [String] -> Q [Dec] +deriveJSONExtendFields opts name fieldStringsToExtend = do + TyConI datad <- reify name + let DataD _ _ _ _ [con] _ = datad + RecC conName varbangtyps = con + fields = map (\(n,_,_) -> n) varbangtyps + conType = ConT name + + fieldNames = map (\(n,_,_) -> n) varbangtyps + lookupFields s = + case filter ((== s) . nameBase) fieldNames of + [n] -> pure n + _ -> fail $ "Couldn't find field to extend: " <> s + + -- Need to convert from strings of fields -> names of fields + fieldsToExtend <- mapM lookupFields fieldStringsToExtend + + to <- deriveToJSONExtendFields opts (pure conType) fields fieldsToExtend + from <- deriveFromJSONExtendFields opts conType conName fields fieldsToExtend + return (to ++ from) + +{- +-- Note: in extends, we need to put the x there to disambiguate in the presence of + duplicate record fields + +instance ToJSON Foo where + toJSON x = Object (mconcat (mainObj:extendMaps)) + where extends = map [toJSON (_baz (x :: Foo))] + unwrapObj (Object hm) = hm + extendMaps = map unwrapObj extends + mainObj = HM.fromList [("_foo", toJSON (_foo (x :: Foo)))] +-} +deriveToJSONExtendFields :: Options -> TypeQ -> [Name] -> [Name] -> Q [Dec] +deriveToJSONExtendFields opts typ fields fieldsToExtend = do + xName <- newName "x" + let mkToJSON :: Name -> ExpQ + mkToJSON n = [e| toJSON ($(varE n) ($(varE xName) :: $typ))|] + mkHMTuple fieldName = + [e| (fromString $(stringE (fieldLabelModifier opts (nameBase fieldName))) + , toJSON ($(varE fieldName) ($(varE xName) :: $typ ))) |] + + [d| instance ToJSON $typ where + toJSON $(varP xName) = Object (mconcat (mainObj:extendMaps)) + where extends = $(listE (mkToJSON <$> fieldsToExtend)) + unwrapObj (Object hm) = hm + extendMaps = map unwrapObj extends + mainObj = HM.fromList + $(listE (mkHMTuple <$> (fields \\ fieldsToExtend))) + |] + where + +{- +instance FromJSON Foo where + parseJSON o@(Object v) = + Foo <$> parseJSON o <*> v .: "foo" + parseJSON _ = mempty +-} +deriveFromJSONExtendFields :: Options -> Type -> Name -> [Name] -> [Name] -> Q [Dec] +deriveFromJSONExtendFields opts typ tyConName fields fieldsToExtend = do + oName <- newName "_o" -- the object name + vName <- newName "_v" -- the value name + ConE objectName <- [e| Object |] + + let fieldExprs = map mkParseExp fields + pat = asP oName (conP objectName [varP vName]) + apArgs :: [ExpQ] -> ExpQ + apArgs [] = error "No arguments!" + apArgs [e] = e + apArgs [e,e'] = [e| $e <$> $e' |] + apArgs es = [e| $(apArgs (init es)) <*> $(last es) |] + + mkParseExp fieldName + | fieldName `elem` fieldsToExtend = [e| parseJSON $(varE oName) |] + | otherwise = + [e| $(varE vName) .: fromString $(stringE (fieldLabelModifier opts (nameBase fieldName))) |] + + [d| instance FromJSON $(pure typ) where + parseJSON $pat = $(apArgs ((conE tyConName):fieldExprs)) + parseJSON _ = mempty + |] + +makeRegHelper :: Name -> DecsQ +makeRegHelper regOptTypeName = do + Just sMethodTypeName <- lookupTypeName "SMethod" + Just fromClientName <- lookupValueName "FromClient" + TyConI (DataD _ _ _ _ allCons _) <- reify sMethodTypeName + + let isConsFromClient (GadtC _ _ (AppT _ method)) = isMethodFromClient method + isConsFromClient _ = return False + isMethodFromClient :: Type -> Q Bool + isMethodFromClient (PromotedT method) = do + typ <- reifyType method + case typ of + AppT (AppT _ (PromotedT n)) _ -> return $ n == fromClientName + _ -> return False + isMethodFromClient _ = fail "Didn't expect this type of Method!" + + cons <- filterM isConsFromClient allCons + + let conNames = map (\(GadtC [name] _ _) -> name) cons + helperName = mkName "regHelper" + mkClause name = do + x <- newName "x" + clause [ conP name [], varP x ] + (normalB (varE x)) + [] + regOptTcon = conT regOptTypeName + fun <- funD helperName (map mkClause conNames) + + typSig <- sigD helperName $ + [t| forall m x. $(conT sMethodTypeName) m + -> (Show ($regOptTcon m) => ToJSON ($regOptTcon m) => FromJSON ($regOptTcon m) => x) + -> x |] + return [typSig, fun] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs index 1186f3a1f..f8bd91585 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs @@ -2,17 +2,12 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFunctor #-} module Language.Haskell.LSP.Types.Window where -import Control.Applicative -import Control.Monad (unless) import qualified Data.Aeson as A import Data.Aeson.TH -import Data.Maybe (catMaybes) import Data.Text (Text) import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.Progress -- --------------------------------------------------------------------- {- @@ -192,293 +187,3 @@ data LogMessageParams = } deriving (Show, Read, Eq) deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''LogMessageParams - -{- -Progress Begin Notification - -To start progress reporting a $/progress notification with the following payload must be sent: - -export interface WorkDoneProgressBegin { - - kind: 'begin'; - - /** - * Mandatory title of the progress operation. Used to briefly inform about - * the kind of operation being performed. - * - * Examples: "Indexing" or "Linking dependencies". - */ - title: string; - - /** - * Controls if a cancel button should show to allow the user to cancel the - * long running operation. Clients that don't support cancellation are allowed - * to ignore the setting. - */ - cancellable?: boolean; - - /** - * Optional, more detailed associated progress message. Contains - * complementary information to the `title`. - * - * Examples: "3/25 files", "project/src/module2", "node_modules/some_dep". - * If unset, the previous progress message (if any) is still valid. - */ - message?: string; - - /** - * Optional progress percentage to display (value 100 is considered 100%). - * If not provided infinite progress is assumed and clients are allowed - * to ignore the `percentage` value in subsequent in report notifications. - * - * The value should be steadily rising. Clients are free to ignore values - * that are not following this rule. - */ - percentage?: number; --} - --- | Parameters for a $/progress notification. -data ProgressParams t = - ProgressParams { - _token :: ProgressToken - , _value :: t - } deriving (Show, Read, Eq, Functor) - -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ProgressParams - -data SomeProgressParams - = Begin WorkDoneProgressBeginParams - | Report WorkDoneProgressReportParams - | End WorkDoneProgressEndParams - deriving Eq - -instance A.FromJSON SomeProgressParams where - parseJSON x = - (Begin <$> A.parseJSON x) - <|> (Report <$> A.parseJSON x) - <|> (End <$> A.parseJSON x) - -instance A.ToJSON SomeProgressParams where - toJSON (Begin x) = A.toJSON x - toJSON (Report x) = A.toJSON x - toJSON (End x) = A.toJSON x - --- | Parameters for 'WorkDoneProgressBeginNotification'. --- --- @since 0.10.0.0 -data WorkDoneProgressBeginParams = - WorkDoneProgressBeginParams { - -- | Mandatory title of the progress operation. - -- Used to briefly inform about the kind of operation being - -- performed. Examples: "Indexing" or "Linking dependencies". - _title :: Text - -- | Controls if a cancel button should show to allow the user to cancel the - -- long running operation. Clients that don't support cancellation are allowed - -- to ignore the setting. - , _cancellable :: Maybe Bool - -- | Optional, more detailed associated progress - -- message. Contains complementary information to the - -- '_title'. Examples: "3/25 files", - -- "project/src/module2", "node_modules/some_dep". If - -- unset, the previous progress message (if any) is - -- still valid. - , _message :: Maybe Text - -- | Optional progress percentage to display (value 100 is considered 100%). - -- If not provided infinite progress is assumed and clients are allowed - -- to ignore the '_percentage' value in subsequent in report notifications. - -- - -- The value should be steadily rising. Clients are free to ignore values - -- that are not following this rule. - , _percentage :: Maybe Double - } deriving (Show, Read, Eq) - -instance A.ToJSON WorkDoneProgressBeginParams where - toJSON WorkDoneProgressBeginParams{..} = - A.object $ catMaybes - [ Just $ "kind" A..= ("begin" :: Text) - , Just $ "title" A..= _title - , ("cancellable" A..=) <$> _cancellable - , ("message" A..=) <$> _message - , ("percentage" A..=) <$> _percentage - ] - -instance A.FromJSON WorkDoneProgressBeginParams where - parseJSON = A.withObject "WorkDoneProgressBegin" $ \o -> do - kind <- o A..: "kind" - unless (kind == ("begin" :: Text)) $ fail $ "Expected kind \"begin\" but got " ++ show kind - _title <- o A..: "title" - _cancellable <- o A..:? "cancellable" - _message <- o A..:? "message" - _percentage <- o A..:? "percentage" - pure WorkDoneProgressBeginParams{..} - --- | The $/progress begin notification is sent from the server to the --- client to ask the client to start progress. --- --- @since 0.10.0.0 -{- -Progress Report Notification - -Reporting progress is done using the following payload: - -export interface WorkDoneProgressReport { - - kind: 'report'; - - /** - * Controls enablement state of a cancel button. This property is only valid if a cancel - * button got requested in the `WorkDoneProgressStart` payload. - * - * Clients that don't support cancellation or don't support control the button's - * enablement state are allowed to ignore the setting. - */ - cancellable?: boolean; - - /** - * Optional, more detailed associated progress message. Contains - * complementary information to the `title`. - * - * Examples: "3/25 files", "project/src/module2", "node_modules/some_dep". - * If unset, the previous progress message (if any) is still valid. - */ - message?: string; - - /** - * Optional progress percentage to display (value 100 is considered 100%). - * If not provided infinite progress is assumed and clients are allowed - * to ignore the `percentage` value in subsequent in report notifications. - * - * The value should be steadily rising. Clients are free to ignore values - * that are not following this rule. - */ - percentage?: number; -} --} - --- | Parameters for 'WorkDoneProgressReportNotification' --- --- @since 0.10.0.0 -data WorkDoneProgressReportParams = - WorkDoneProgressReportParams { - _cancellable :: Maybe Bool - -- | Optional, more detailed associated progress - -- message. Contains complementary information to the - -- '_title'. Examples: "3/25 files", - -- "project/src/module2", "node_modules/some_dep". If - -- unset, the previous progress message (if any) is - -- still valid. - , _message :: Maybe Text - -- | Optional progress percentage to display (value 100 is considered 100%). - -- If infinite progress was indicated in the start notification client - -- are allowed to ignore the value. In addition the value should be steadily - -- rising. Clients are free to ignore values that are not following this rule. - , _percentage :: Maybe Double - } deriving (Show, Read, Eq) - -instance A.ToJSON WorkDoneProgressReportParams where - toJSON WorkDoneProgressReportParams{..} = - A.object $ catMaybes - [ Just $ "kind" A..= ("report" :: Text) - , ("cancellable" A..=) <$> _cancellable - , ("message" A..=) <$> _message - , ("percentage" A..=) <$> _percentage - ] - -instance A.FromJSON WorkDoneProgressReportParams where - parseJSON = A.withObject "WorkDoneProgressReport" $ \o -> do - kind <- o A..: "kind" - unless (kind == ("report" :: Text)) $ fail $ "Expected kind \"report\" but got " ++ show kind - _cancellable <- o A..:? "cancellable" - _message <- o A..:? "message" - _percentage <- o A..:? "percentage" - pure WorkDoneProgressReportParams{..} - --- | The workdone $/progress report notification is sent from the server to the --- client to report progress for a previously started progress. --- --- @since 0.10.0.0 -{- -Progress End Notification - -Signaling the end of a progress reporting is done using the following payload: - -export interface WorkDoneProgressEnd { - - kind: 'end'; - - /** - * Optional, a final message indicating to for example indicate the outcome - * of the operation. - */ - message?: string; -} --} - --- | Parameters for 'WorkDoneProgressEndNotification'. --- --- @since 0.10.0.0 -data WorkDoneProgressEndParams = - WorkDoneProgressEndParams { - _message :: Maybe Text - } deriving (Show, Read, Eq) - -instance A.ToJSON WorkDoneProgressEndParams where - toJSON WorkDoneProgressEndParams{..} = - A.object $ catMaybes - [ Just $ "kind" A..= ("end" :: Text) - , ("message" A..=) <$> _message - ] - -instance A.FromJSON WorkDoneProgressEndParams where - parseJSON = A.withObject "WorkDoneProgressEnd" $ \o -> do - kind <- o A..: "kind" - unless (kind == ("end" :: Text)) $ fail $ "Expected kind \"end\" but got " ++ show kind - _message <- o A..:? "message" - pure WorkDoneProgressEndParams{..} - --- | The $/progress end notification is sent from the server to the --- client to stop a previously started progress. --- --- @since 0.10.0.0 -{- -Progress Cancel Notification - -The window/workDoneProgress/cancel notification is sent from the client to the server to inform the server that the user has pressed the cancel button on the progress UX. A server receiving a cancel request must still close a progress using the done notification. - -Notification: - -method: 'window/workDoneProgress/cancel' -params: WorkDoneProgressCancelParams defined as follows: -export interface WorkDoneProgressCancelParams { - /** - * The token to be used to report progress. - */ - token: ProgressToken; -} --} - --- | Parameters for 'WorkDoneProgressCancelNotification'. --- --- @since 0.10.0.0 -data WorkDoneProgressCancelParams = - WorkDoneProgressCancelParams { - -- | A unique identifier to associate multiple progress - -- notifications with the same progress. - _token :: ProgressToken - } deriving (Show, Read, Eq) - -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressCancelParams - --- | The window/workDoneProgress/cancel notification is sent from the client to the server --- to inform the server that the user has pressed the cancel button on the progress UX. --- A server receiving a cancel request must still close a progress using the done notification. --- --- @since 0.10.0.0 - -data WorkDoneProgressCreateParams = - WorkDoneProgressCreateParams { - _token :: ProgressToken - } deriving (Show, Read, Eq) - -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressCreateParams - From aba72814d31097dd43121a17cc2e4eb6d75df87d Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 4 Aug 2020 16:38:43 +0100 Subject: [PATCH 03/63] Start makeExtendingDatatype and update Core.hs for new ServerCapabilities --- .../src/Language/Haskell/LSP/Types.hs | 10 +++ .../Haskell/LSP/Types/Capabilities.hs | 2 + .../Language/Haskell/LSP/Types/CodeAction.hs | 3 +- .../Language/Haskell/LSP/Types/CodeLens.hs | 3 +- .../src/Language/Haskell/LSP/Types/Hover.hs | 4 ++ .../Language/Haskell/LSP/Types/References.hs | 4 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 3 + .../Haskell/LSP/Types/TextDocument.hs | 3 +- .../src/Language/Haskell/LSP/Types/Utils.hs | 17 +++++ hie.yaml | 5 +- src/Language/Haskell/LSP/Core.hs | 63 ++++++++++--------- test/InitialConfigurationSpec.hs | 7 +-- 12 files changed, 84 insertions(+), 40 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index d5e59de40..a0521096e 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -1,6 +1,7 @@ module Language.Haskell.LSP.Types ( module Language.Haskell.LSP.Types.DataTypesJSON , module Language.Haskell.LSP.Types.CodeAction + , module Language.Haskell.LSP.Types.CodeLens , module Language.Haskell.LSP.Types.Color , module Language.Haskell.LSP.Types.Command , module Language.Haskell.LSP.Types.Completion @@ -8,6 +9,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.Empty , module Language.Haskell.LSP.Types.FoldingRange + , module Language.Haskell.LSP.Types.Formatting , module Language.Haskell.LSP.Types.Hover , module Language.Haskell.LSP.Types.List , module Language.Haskell.LSP.Types.Location @@ -16,6 +18,9 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Method , module Language.Haskell.LSP.Types.Message , module Language.Haskell.LSP.Types.Progress + , module Language.Haskell.LSP.Types.References + , module Language.Haskell.LSP.Types.Rename + , module Language.Haskell.LSP.Types.StaticRegistrationOptions , module Language.Haskell.LSP.Types.Symbol , module Language.Haskell.LSP.Types.Synonyms , module Language.Haskell.LSP.Types.TextDocument @@ -28,6 +33,7 @@ where import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.CodeAction +import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion @@ -35,6 +41,7 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location @@ -43,6 +50,9 @@ import Language.Haskell.LSP.Types.MarkupContent import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.Synonyms import Language.Haskell.LSP.Types.TextDocument diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 24a695a56..a7c4332cd 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -1,6 +1,7 @@ module Language.Haskell.LSP.Types.Capabilities ( module Language.Haskell.LSP.Types.ClientCapabilities + , module Language.Haskell.LSP.Types.ServerCapabilities , fullCaps , LSPVersion(..) , capsForVersion @@ -8,6 +9,7 @@ module Language.Haskell.LSP.Types.Capabilities import Prelude hiding (min) import Language.Haskell.LSP.Types.ClientCapabilities +import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types -- | The whole shebang. The real deal. diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs index 971801d81..a27edc44e 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs @@ -308,8 +308,7 @@ export interface CodeActionOptions { -} data CodeActionOptions = - CodeActionOptionsStatic Bool - | CodeActionOptions + CodeActionOptions { _codeActionKinds :: Maybe [CodeActionKind] } deriving (Read,Show,Eq) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs index 661448bea..f4bc5190d 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} module Language.Haskell.LSP.Types.CodeLens where diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs index 2a4349649..33ed4219b 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs @@ -162,3 +162,7 @@ data HoverRegistrationOptions = } deriving (Read,Show,Eq) deriveJSONExtendFields lspOptions ''HoverRegistrationOptions ["_textDocumentRegistrationOptions", "_hoverOptions"] + +-- TODO: derive json instances for this +-- makeExtendingDatatype "HoverParams" [''TextDocumentPositionParams, ''WorkDoneProgressParams] + -- [] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs index eff146993..961323053 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} module Language.Haskell.LSP.Types.References where import Data.Aeson.TH @@ -51,7 +52,6 @@ data ReferenceContext = deriveJSON lspOptions ''ReferenceContext - data ReferenceParams = ReferenceParams { _textDocumentPositionParams :: TextDocumentPositionParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index c326904aa..45ec63664 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -26,9 +26,12 @@ import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils +-- | A terser, isomorphic data type for 'Either', that does not get tagged when +-- converting to and from JSON. data a |? b = L a | R b deriving (Read,Show,Eq) +infixr |? instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where toJSON (L x) = toJSON x diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs index 7ed0ddfb2..3e163589f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs @@ -100,7 +100,6 @@ data TextDocumentPositionParams = TextDocumentPositionParams { _textDocument :: TextDocumentIdentifier , _position :: Position - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. } deriving (Show, Read, Eq) deriveJSON lspOptions ''TextDocumentPositionParams @@ -126,4 +125,4 @@ data TextDocumentRegistrationOptions = { _documentSelector :: Maybe DocumentSelector } deriving (Show, Read, Eq) -deriveJSON lspOptions ''TextDocumentRegistrationOptions \ No newline at end of file +deriveJSON lspOptions ''TextDocumentRegistrationOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs index d6a32fb44..f2a55dc15 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs @@ -6,6 +6,7 @@ module Language.Haskell.LSP.Types.Utils , makeSingletonFromJSON , deriveJSONExtendFields , makeRegHelper + , makeExtendingDatatype ) where import qualified Data.HashMap.Strict as HM @@ -14,6 +15,7 @@ import Data.Aeson import Data.String import Control.Monad import Data.List (foldl', (\\)) +import Data.Maybe (fromJust) -- --------------------------------------------------------------------- @@ -166,3 +168,18 @@ makeRegHelper regOptTypeName = do -> (Show ($regOptTcon m) => ToJSON ($regOptTcon m) => FromJSON ($regOptTcon m) => x) -> x |] return [typSig, fun] + +makeExtendingDatatype :: String -> [Name] -> [(String, Name)] -> DecsQ +makeExtendingDatatype datatypeNameStr extends fields = do + extendFields <- fmap concat $ forM extends $ \e -> do + reify e >>= runIO . print + TyConI (DataD _ _ _ _ [RecC _ eFields] _) <- reify e + return eFields + let datatypeName = mkName datatypeNameStr + insts = [[t| Read |], [t| Show |], [t| Eq |]] + constructor = recC datatypeName combinedFields + userFields = flip map fields $ \(s, n) -> do + varBangType (mkName s) (bangType (bang noSourceUnpackedness noSourceStrictness) (conT n)) + combinedFields = (map pure extendFields) <> userFields + derivs = [derivClause Nothing insts] + (\a -> [a]) <$> dataD (cxt []) datatypeName [] Nothing [constructor] derivs diff --git a/hie.yaml b/hie.yaml index a1ccc46a8..ce7f616b4 100644 --- a/hie.yaml +++ b/hie.yaml @@ -7,4 +7,7 @@ # https://github.com/digital-asset/ghcide/issues/113 cradle: cabal: - component: "haskell-lsp" + - path: "./haskell-lsp-types" + component: "haskell-lsp-types" + - path: "./src" + component: "haskell-lsp" diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 677bfc185..113cf7db6 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -67,7 +67,7 @@ import qualified Data.Text as T import Data.Text ( Text ) import Language.Haskell.LSP.Constant -- import Language.Haskell.LSP.Types.MessageFuncs -import qualified Language.Haskell.LSP.Types.Capabilities as C +import qualified Language.Haskell.LSP.Types.Capabilities as J import Language.Haskell.LSP.Types as J hiding (Progress) import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.Utility @@ -142,7 +142,7 @@ readData f = do -- If you set handlers for some requests, you may need to set some of these options. data Options = Options - { textDocumentSync :: Maybe TextDocumentSyncOptions + { textDocumentSync :: Maybe J.TextDocumentSyncOptions -- | The characters that trigger completion automatically. , completionTriggerCharacters :: Maybe [Char] -- | The list of all possible characters that commit a completion. This field can be used @@ -215,7 +215,7 @@ type SendNotifcationFunc = forall m. -- | Returned to the server on startup, providing ways to interact with the client. data LspFuncs c = LspFuncs - { clientCapabilities :: !C.ClientCapabilities + { clientCapabilities :: !J.ClientCapabilities , config :: !(IO (Maybe c)) -- ^ Derived from the DidChangeConfigurationNotification message via a -- server-provided function. @@ -555,16 +555,16 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r let clientSupportsWfs = fromMaybe False $ do - let (C.ClientCapabilities mw _ _ _) = params ^. J.capabilities - (C.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw + let (J.ClientCapabilities mw _ _ _) = params ^. J.capabilities + (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw mwf getWfs tvc | clientSupportsWfs = atomically $ Just . resWorkspaceFolders <$> readTVar tvc | otherwise = return Nothing clientSupportsProgress = fromMaybe False $ do - let (C.ClientCapabilities _ _ wc _) = params ^. J.capabilities - (C.WindowClientCapabilities mProgress) <- wc + let (J.ClientCapabilities _ _ wc _) = params ^. J.capabilities + (J.WindowClientCapabilities mProgress) <- wc mProgress @@ -701,37 +701,42 @@ withIndefiniteProgress' title cancellable f = -- | Infers the capabilities based on registered handlers, and sets the appropriate options. -- A provider should be set to Nothing if the server does not support it, unless it is a -- static option. -serverCapabilities :: C.ClientCapabilities -> Options -> Handlers -> J.InitializeResponseCapabilitiesInner +serverCapabilities :: J.ClientCapabilities -> Options -> Handlers -> J.ServerCapabilities serverCapabilities clientCaps o h = - J.InitializeResponseCapabilitiesInner + J.ServerCapabilities { J._textDocumentSync = sync - , J._hoverProvider = supported J.STextDocumentHover + , J._hoverProvider = supportedBool J.STextDocumentHover , J._completionProvider = completionProvider , J._signatureHelpProvider = signatureHelpProvider - , J._definitionProvider = supported J.STextDocumentDefinition - , J._typeDefinitionProvider = Just $ J.GotoOptionsStatic $ supported_b J.STextDocumentTypeDefinition - , J._implementationProvider = Just $ J.GotoOptionsStatic $ supported_b J.STextDocumentImplementation - , J._referencesProvider = supported J.STextDocumentReferences - , J._documentHighlightProvider = supported J.STextDocumentDocumentHighlight - , J._documentSymbolProvider = supported J.STextDocumentDocumentSymbol + , J._definitionProvider = supportedBool J.STextDocumentDefinition + , J._typeDefinitionProvider = supportedBool J.STextDocumentTypeDefinition + , J._implementationProvider = supportedBool J.STextDocumentImplementation + , J._referencesProvider = supportedBool J.STextDocumentReferences + , J._documentHighlightProvider = supportedBool J.STextDocumentDocumentHighlight + , J._documentSymbolProvider = supportedBool J.STextDocumentDocumentSymbol , J._workspaceSymbolProvider = supported J.SWorkspaceSymbol , J._codeActionProvider = codeActionProvider - , J._codeLensProvider = supported' J.STextDocumentCodeLens $ J.CodeLensOptions $ - supported J.SCodeLensResolve - , J._documentFormattingProvider = supported J.STextDocumentFormatting - , J._documentRangeFormattingProvider = supported J.STextDocumentRangeFormatting + , J._codeLensProvider = supported' J.STextDocumentCodeLens $ J.CodeLensOptions + (J.WorkDoneProgressOptions Nothing) + (supported J.SCodeLensResolve) + , J._documentFormattingProvider = supportedBool J.STextDocumentFormatting + , J._documentRangeFormattingProvider = supportedBool J.STextDocumentRangeFormatting , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider - , J._renameProvider = Just $ J.RenameOptionsStatic $ supported_b J.STextDocumentRename + , J._renameProvider = supportedBool J.STextDocumentRename , J._documentLinkProvider = supported' J.STextDocumentDocumentLink $ J.DocumentLinkOptions $ supported J.SDocumentLinkResolve - , J._colorProvider = Just $ J.ColorOptionsStatic $ supported_b J.STextDocumentDocumentColor - , J._foldingRangeProvider = Just $ J.FoldingRangeOptionsStatic $ supported_b J.STextDocumentFoldingRange + , J._colorProvider = supportedBool J.STextDocumentDocumentColor + , J._foldingRangeProvider = supportedBool J.STextDocumentFoldingRange , J._executeCommandProvider = executeCommandProvider , J._workspace = Just workspace -- TODO: Add something for experimental , J._experimental = Nothing :: Maybe J.Value } where + + -- | For when we just return a simple @true@/@false@ to indicate if we + -- support the capability + supportedBool = Just . J.L . supported_b supported' m b | supported_b m = Just b @@ -749,6 +754,7 @@ serverCapabilities clientCaps o h = completionProvider | supported_b J.STextDocumentCompletion = Just $ J.CompletionOptions + (J.WorkDoneProgressOptions Nothing) (supported J.SCompletionItemResolve) (map singleton <$> completionTriggerCharacters o) (map singleton <$> completionAllCommitCharacters o) @@ -759,13 +765,14 @@ serverCapabilities clientCaps o h = codeActionProvider | clientSupportsCodeActionKinds - , supported_b J.STextDocumentCodeAction = Just $ maybe (J.CodeActionOptionsStatic True) (J.CodeActionOptions . Just) (codeActionKinds o) - | supported_b J.STextDocumentCodeAction = Just (J.CodeActionOptionsStatic True) - | otherwise = Just (J.CodeActionOptionsStatic False) + , supported_b J.STextDocumentCodeAction = Just $ maybe (J.L True) (J.R . J.CodeActionOptions . Just) (codeActionKinds o) + | supported_b J.STextDocumentCodeAction = Just (J.L True) + | otherwise = Just (J.L False) signatureHelpProvider | supported_b J.STextDocumentSignatureHelp = Just $ J.SignatureHelpOptions + (J.WorkDoneProgressOptions Nothing) (map singleton <$> signatureHelpTriggerCharacters o) (map singleton <$> signatureHelpRetriggerCharacters o) | otherwise = Nothing @@ -791,10 +798,10 @@ serverCapabilities clientCaps o h = Just x -> Just (J.TDSOptions x) Nothing -> Nothing - workspace = J.WorkspaceOptions workspaceFolder + workspace = J.WorkspaceServerCapabilities workspaceFolder workspaceFolder = supported' J.SWorkspaceDidChangeWorkspaceFolders $ -- sign up to receive notifications - J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True)) + J.WorkspaceFoldersServerCapabilities (Just True) (Just (J.R True)) progressCancelHandler :: J.WorkDoneProgressCancelNotification -> LspM config () progressCancelHandler (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do diff --git a/test/InitialConfigurationSpec.hs b/test/InitialConfigurationSpec.hs index 712254307..43b6302e3 100644 --- a/test/InitialConfigurationSpec.hs +++ b/test/InitialConfigurationSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, GADTs #-} module InitialConfigurationSpec where @@ -19,8 +19,7 @@ spec = lfVar <- newEmptyMVar - let - initialConfigHandler (RequestMessage _ _ Initialize InitializeParams{_initializationOptions = Just opts}) = + let initialConfigHandler (RequestMessage _ _ SInitialize InitializeParams{_initializationOptions = Just opts}) = case (fromJSON opts :: Result String) of Success s -> Right s _ -> Left "Could not decode configuration" @@ -58,7 +57,7 @@ spec = Nothing initMsg :: InitializeRequest - initMsg = RequestMessage "2.0" (IdInt 0) Initialize initParams + initMsg = RequestMessage "2.0" (IdInt 0) SInitialize initParams putMsg initMsg contents <- readTVarIO tvarCtx From 7f3b0f28d12e28f770ca7b814b2fd18a267af692 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 12 Aug 2020 15:27:03 +0100 Subject: [PATCH 04/63] First pass at a full split-out and update of the 3.15 spec Currently chewing through the langauge features Done completion, completion resolve, hover, signature help Moving everything in clientcapabilities/servercapabilities into the respective modules. Rewriting things to use makeExtendingDatatype. Deleting a lot of the copied + pasted in parts of the speification as most of them are out of date --- haskell-lsp-types/haskell-lsp-types.cabal | 6 +- .../src/Language/Haskell/LSP/Types.hs | 6 +- .../Haskell/LSP/Types/Capabilities.hs | 5 +- .../Haskell/LSP/Types/ClientCapabilities.hs | 114 +----- .../Language/Haskell/LSP/Types/CodeAction.hs | 3 +- .../Language/Haskell/LSP/Types/CodeLens.hs | 1 - .../src/Language/Haskell/LSP/Types/Color.hs | 3 +- .../src/Language/Haskell/LSP/Types/Command.hs | 5 +- .../src/Language/Haskell/LSP/Types/Common.hs | 46 +++ .../Language/Haskell/LSP/Types/Completion.hs | 386 ++++-------------- .../Language/Haskell/LSP/Types/Constants.hs | 17 - .../Haskell/LSP/Types/DataTypesJSON.hs | 153 +------ .../Language/Haskell/LSP/Types/Diagnostic.hs | 4 +- .../Haskell/LSP/Types/DocumentFilter.hs | 4 +- .../Haskell/LSP/Types/DocumentHighlight.hs | 1 - .../Haskell/LSP/Types/FoldingRange.hs | 1 - .../Language/Haskell/LSP/Types/Formatting.hs | 1 - .../src/Language/Haskell/LSP/Types/Hover.hs | 100 +---- .../src/Language/Haskell/LSP/Types/Lens.hs | 8 +- .../src/Language/Haskell/LSP/Types/List.hs | 31 -- .../Language/Haskell/LSP/Types/Location.hs | 4 +- .../Haskell/LSP/Types/MarkupContent.hs | 2 +- .../src/Language/Haskell/LSP/Types/Message.hs | 9 +- .../Language/Haskell/LSP/Types/Progress.hs | 2 +- .../Language/Haskell/LSP/Types/References.hs | 81 +--- .../Haskell/LSP/Types/Registration.hs | 4 +- .../src/Language/Haskell/LSP/Types/Rename.hs | 2 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 53 +-- .../Haskell/LSP/Types/SignatureHelp.hs | 154 +++++++ .../LSP/Types/StaticRegistrationOptions.hs | 2 +- .../src/Language/Haskell/LSP/Types/Symbol.hs | 4 +- .../Haskell/LSP/Types/TextDocument.hs | 4 +- .../src/Language/Haskell/LSP/Types/Utils.hs | 24 +- .../src/Language/Haskell/LSP/Types/Window.hs | 2 +- .../Haskell/LSP/Types/WorkspaceEdit.hs | 5 +- .../Haskell/LSP/Types/WorkspaceFolders.hs | 5 +- 36 files changed, 402 insertions(+), 850 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs delete mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Constants.hs delete mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/List.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/SignatureHelp.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index 39867472d..8af21cd61 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -19,15 +19,14 @@ cabal-version: >=1.10 library exposed-modules: Language.Haskell.LSP.Types , Language.Haskell.LSP.Types.Capabilities - , Language.Haskell.LSP.Types.Constants , Language.Haskell.LSP.Types.Lens - , Language.Haskell.LSP.Types.Utils , Data.IxMap other-modules: Language.Haskell.LSP.Types.ClientCapabilities , Language.Haskell.LSP.Types.CodeAction , Language.Haskell.LSP.Types.CodeLens , Language.Haskell.LSP.Types.Color , Language.Haskell.LSP.Types.Command + , Language.Haskell.LSP.Types.Common , Language.Haskell.LSP.Types.Completion , Language.Haskell.LSP.Types.DataTypesJSON , Language.Haskell.LSP.Types.Diagnostic @@ -36,7 +35,6 @@ library , Language.Haskell.LSP.Types.FoldingRange , Language.Haskell.LSP.Types.Formatting , Language.Haskell.LSP.Types.Hover - , Language.Haskell.LSP.Types.List , Language.Haskell.LSP.Types.Location , Language.Haskell.LSP.Types.LspId , Language.Haskell.LSP.Types.Empty @@ -48,11 +46,13 @@ library , Language.Haskell.LSP.Types.References , Language.Haskell.LSP.Types.Rename , Language.Haskell.LSP.Types.ServerCapabilities + , Language.Haskell.LSP.Types.SignatureHelp , Language.Haskell.LSP.Types.StaticRegistrationOptions , Language.Haskell.LSP.Types.Symbol , Language.Haskell.LSP.Types.Synonyms , Language.Haskell.LSP.Types.TextDocument , Language.Haskell.LSP.Types.Uri + , Language.Haskell.LSP.Types.Utils , Language.Haskell.LSP.Types.Window , Language.Haskell.LSP.Types.WorkspaceEdit , Language.Haskell.LSP.Types.WorkspaceFolders diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index a0521096e..e1a2fe081 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -4,6 +4,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.CodeLens , module Language.Haskell.LSP.Types.Color , module Language.Haskell.LSP.Types.Command + , module Language.Haskell.LSP.Types.Common , module Language.Haskell.LSP.Types.Completion , module Language.Haskell.LSP.Types.Diagnostic , module Language.Haskell.LSP.Types.DocumentFilter @@ -11,7 +12,6 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.FoldingRange , module Language.Haskell.LSP.Types.Formatting , module Language.Haskell.LSP.Types.Hover - , module Language.Haskell.LSP.Types.List , module Language.Haskell.LSP.Types.Location , module Language.Haskell.LSP.Types.LspId , module Language.Haskell.LSP.Types.MarkupContent @@ -20,6 +20,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Progress , module Language.Haskell.LSP.Types.References , module Language.Haskell.LSP.Types.Rename + , module Language.Haskell.LSP.Types.SignatureHelp , module Language.Haskell.LSP.Types.StaticRegistrationOptions , module Language.Haskell.LSP.Types.Symbol , module Language.Haskell.LSP.Types.Synonyms @@ -43,7 +44,7 @@ import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.MarkupContent @@ -52,6 +53,7 @@ import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.Synonyms diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index a7c4332cd..7a12d89b5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -191,10 +191,11 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth SignatureHelpClientCapabilities dynamicReg (Just signatureInformationCapability) + Nothing signatureInformationCapability = - SignatureInformationClientCapabilities - (Just (List [MkPlainText, MkMarkdown])) + SignatureHelpSignatureInformation + (Just (List [MkPlainText, MkMarkdown])) Nothing documentSymbolCapability = DocumentSymbolClientCapabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index fc282bc14..96b82bb4d 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -6,13 +6,15 @@ module Language.Haskell.LSP.Types.ClientCapabilities where import Data.Aeson.TH import qualified Data.Aeson as A import Data.Default -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Diagnostic -import Language.Haskell.LSP.Types.List -import Language.Haskell.LSP.Types.MarkupContent +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Hover +import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- {- @@ -636,113 +638,7 @@ $(deriveJSON lspOptions ''SynchronizationTextDocumentClientCapabilities) instance Default SynchronizationTextDocumentClientCapabilities where def = SynchronizationTextDocumentClientCapabilities def def def def --- ------------------------------------- - -data CompletionItemTagsClientCapabilities = - CompletionItemTagsClientCapabilities - { -- | The tag supported by the client. - _valueSet :: List CompletionItemTag - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''CompletionItemTagsClientCapabilities) - -data CompletionItemClientCapabilities = - CompletionItemClientCapabilities - { -- | Client supports snippets as insert text. - -- - -- A snippet can define tab stops and placeholders with `$1`, `$2` and - -- `${3:foo}`. `$0` defines the final tab stop, it defaults to the end of - -- the snippet. Placeholders with equal identifiers are linked, that is - -- typing in one will update others too. - _snippetSupport :: Maybe Bool - - -- | Client supports commit characters on a completion item. - , _commitCharactersSupport :: Maybe Bool - - -- | Client supports the follow content formats for the documentation - -- property. The order describes the preferred format of the client. - , _documentationFormat :: Maybe (List MarkupKind) - - -- | Client supports the deprecated property on a completion item. - , _deprecatedSupport :: Maybe Bool - - -- | Client supports the preselect property on a completion item. - , _preselectSupport :: Maybe Bool - - -- | Client supports the tag property on a completion item. Clients - -- supporting tags have to handle unknown tags gracefully. Clients - -- especially need to preserve unknown tags when sending a - -- completion item back to the server in a resolve call. - , _tagSupport :: Maybe CompletionItemTagsClientCapabilities - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''CompletionItemClientCapabilities) - -data CompletionItemKindClientCapabilities = - CompletionItemKindClientCapabilities - { -- | The completion item kind values the client supports. When this - -- property exists the client also guarantees that it will - -- handle values outside its set gracefully and falls back - -- to a default value when unknown. - _valueSet :: Maybe (List CompletionItemKind) - } - deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''CompletionItemKindClientCapabilities) - -data CompletionClientCapabilities = - CompletionClientCapabilities - { _dynamicRegistration :: Maybe Bool -- ^Whether completion supports dynamic - -- registration. - , _completionItem :: Maybe CompletionItemClientCapabilities - , _completionItemKind :: Maybe CompletionItemKindClientCapabilities - , _contextSupport :: Maybe Bool - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''CompletionClientCapabilities) - --- ------------------------------------- - -data HoverClientCapabilities = - HoverClientCapabilities - { _dynamicRegistration :: Maybe Bool - , _contentFormat :: Maybe (List MarkupKind) - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''HoverClientCapabilities) - --- ------------------------------------- - -data SignatureInformationClientCapabilities = - SignatureInformationClientCapabilities - { -- | Client supports the follow content formats for the documentation - -- property. The order describes the preferred format of the client. - documentationFormat :: Maybe (List MarkupKind) - } - deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''SignatureInformationClientCapabilities) - -data SignatureHelpClientCapabilities = - SignatureHelpClientCapabilities - { -- | Whether signature help supports dynamic registration. - _dynamicRegistration :: Maybe Bool - - -- | The client supports the following `SignatureInformation` - -- specific properties. - , _signatureInformation :: Maybe SignatureInformationClientCapabilities - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''SignatureHelpClientCapabilities) - --- ------------------------------------- - -data ReferencesClientCapabilities = - ReferencesClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ReferencesClientCapabilities) -- ------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs index a27edc44e..855399edf 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs @@ -8,9 +8,8 @@ import Data.Aeson.TH import Data.Aeson.Types import Data.Text ( Text ) import Language.Haskell.LSP.Types.Command -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Diagnostic -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs index f4bc5190d..6a02ef2bc 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs @@ -6,7 +6,6 @@ module Language.Haskell.LSP.Types.CodeLens where import Data.Aeson import Data.Aeson.TH import Language.Haskell.LSP.Types.Command -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs index 887b09bc5..b5cbd20d7 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs @@ -4,8 +4,7 @@ module Language.Haskell.LSP.Types.Color where import Data.Aeson.TH import Data.Text ( Text ) -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.StaticRegistrationOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs index dfb346a6a..81f71ce82 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs @@ -5,8 +5,9 @@ module Language.Haskell.LSP.Types.Command where import Data.Aeson import Data.Aeson.TH import Data.Text -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Utils + -- --------------------------------------------------------------------- {- Command diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs new file mode 100644 index 000000000..8c0e7df33 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +-- | Common types that aren't in the specification +module Language.Haskell.LSP.Types.Common where + +import Control.Applicative +import Control.DeepSeq +import Data.Aeson +import GHC.Generics + +-- | A terser, isomorphic data type for 'Either', that does not get tagged when +-- converting to and from JSON. +data a |? b = L a + | R b + deriving (Read,Show,Eq) +infixr |? + +instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where + toJSON (L x) = toJSON x + toJSON (R x) = toJSON x + +instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where + parseJSON v = L <$> parseJSON v <|> R <$> parseJSON v + +-- | This data type is used to host a FromJSON instance for the encoding used by +-- elisp, where an empty list shows up as "null" +newtype List a = List [a] + deriving (Show,Read,Eq,Ord,Monoid,Functor,Foldable,Traversable,Generic) + +instance NFData a => NFData (List a) + +instance (ToJSON a) => ToJSON (List a) where + toJSON (List ls) = toJSON ls + +instance (FromJSON a) => FromJSON (List a) where + parseJSON Null = return (List []) + parseJSON v = List <$> parseJSON v + +#if __GLASGOW_HASKELL__ >= 804 +instance Semigroup (List a) where + (<>) = mappend +#endif diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs index c3460cf7e..b1a5dbc7f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs @@ -9,10 +9,7 @@ import Data.Aeson.TH import Data.Scientific ( Scientific ) import Data.Text ( Text ) import Language.Haskell.LSP.Types.Command -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.DocumentFilter -import Language.Haskell.LSP.Types.List -import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.MarkupContent import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument @@ -113,191 +110,68 @@ instance A.FromJSON CompletionItemTag where parseJSON (A.Number 1) = pure CtDeprecated parseJSON _ = mempty --- --------------------------------------------------------------------- -{- -Completion Request +data CompletionItemTagsClientCapabilities = + CompletionItemTagsClientCapabilities + { -- | The tag supported by the client. + _valueSet :: List CompletionItemTag + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CompletionItemTagsClientCapabilities -The Completion request is sent from the client to the server to compute -completion items at a given cursor position. Completion items are presented in -the IntelliSense user interface. If computing full completion items is -expensive, servers can additionally provide a handler for the completion item -resolve request ('completionItem/resolve'). This request is sent when a -completion item is selected in the user interface. A typically use case is for -example: the 'textDocument/completion' request doesn't fill in the documentation -property for returned completion items since it is expensive to compute. When -the item is selected in the user interface then a 'completionItem/resolve' -request is sent with the selected completion item as a param. The returned -completion item should have the documentation property filled in. +data CompletionItemClientCapabilities = + CompletionItemClientCapabilities + { -- | Client supports snippets as insert text. + -- + -- A snippet can define tab stops and placeholders with `$1`, `$2` and + -- `${3:foo}`. `$0` defines the final tab stop, it defaults to the end of + -- the snippet. Placeholders with equal identifiers are linked, that is + -- typing in one will update others too. + _snippetSupport :: Maybe Bool + + -- | Client supports commit characters on a completion item. + , _commitCharactersSupport :: Maybe Bool + + -- | Client supports the follow content formats for the documentation + -- property. The order describes the preferred format of the client. + , _documentationFormat :: Maybe (List MarkupKind) + + -- | Client supports the deprecated property on a completion item. + , _deprecatedSupport :: Maybe Bool + + -- | Client supports the preselect property on a completion item. + , _preselectSupport :: Maybe Bool + + -- | Client supports the tag property on a completion item. Clients + -- supporting tags have to handle unknown tags gracefully. Clients + -- especially need to preserve unknown tags when sending a + -- completion item back to the server in a resolve call. + , _tagSupport :: Maybe CompletionItemTagsClientCapabilities + } deriving (Show, Read, Eq) - Changed: In 2.0 the request uses TextDocumentPositionParams with a proper - textDocument and position property. In 1.0 the uri of the referenced text - document was inlined into the params object. +deriveJSON lspOptions ''CompletionItemClientCapabilities -Request +data CompletionItemKindClientCapabilities = + CompletionItemKindClientCapabilities + { -- | The completion item kind values the client supports. When this + -- property exists the client also guarantees that it will + -- handle values outside its set gracefully and falls back + -- to a default value when unknown. + _valueSet :: Maybe (List CompletionItemKind) + } + deriving (Show, Read, Eq) - method: 'textDocument/completion' - params: TextDocumentPositionParams --} +deriveJSON lspOptions ''CompletionItemKindClientCapabilities --- ------------------------------------- +data CompletionClientCapabilities = + CompletionClientCapabilities + { _dynamicRegistration :: Maybe Bool -- ^ Whether completion supports dynamic + -- registration. + , _completionItem :: Maybe CompletionItemClientCapabilities + , _completionItemKind :: Maybe CompletionItemKindClientCapabilities + , _contextSupport :: Maybe Bool + } deriving (Show, Read, Eq) -{- - -Response - - result: CompletionItem[] | CompletionList - -/** - * Represents a collection of [completion items](#CompletionItem) to be presented - * in the editor. - */ -interface CompletionList { - /** - * This list it not complete. Further typing should result in recomputing - * this list. - */ - isIncomplete: boolean; - /** - * The completion items. - */ - items: CompletionItem[]; -} - - -New in 3.0 : InsertTextFormat - -/** - * Defines whether the insert text in a completion item should be interpreted as - * plain text or a snippet. - */ -namespace InsertTextFormat { - /** - * The primary text to be inserted is treated as a plain string. - */ - export const PlainText = 1; - - /** - * The primary text to be inserted is treated as a snippet. - * - * A snippet can define tab stops and placeholders with `$1`, `$2` - * and `${3:foo}`. `$0` defines the final tab stop, it defaults to - * the end of the snippet. Placeholders with equal identifiers are linked, - * that is typing in one will update others too. - * - * See also: https://github.com/Microsoft/vscode/blob/master/src/vs/editor/contrib/snippet/common/snippet.md - */ - export const Snippet = 2; -} - - - -interface CompletionItem { - /** - * The label of this completion item. By default - * also the text that is inserted when selecting - * this completion. - */ - label: string; - /** - * The kind of this completion item. Based of the kind - * an icon is chosen by the editor. - */ - kind?: number; - /** - * Tags for this completion item. - */ - tags?: CompletionItemTag[]; - /** - * A human-readable string with additional information - * about this item, like type or symbol information. - */ - detail?: string; - /** - * A human-readable string that represents a doc-comment. - */ - documentation?: string; - /** - * A string that shoud be used when comparing this item - * with other items. When `falsy` the label is used. - */ - sortText?: string; - /** - * A string that should be used when filtering a set of - * completion items. When `falsy` the label is used. - */ - filterText?: string; - /** - * A string that should be inserted a document when selecting - * this completion. When `falsy` the label is used. - */ - insertText?: string; - -- Following field is new in 3.0 - /** - * The format of the insert text. The format applies to both the `insertText` property - * and the `newText` property of a provided `textEdit`. - */ - insertTextFormat?: InsertTextFormat; - /** - * An edit which is applied to a document when selecting this completion. When an edit is provided the value of - * `insertText` is ignored. - * - * *Note:* The range of the edit must be a single line range and it must contain the position at which completion - * has been requested. - */ - - textEdit?: TextEdit; - - -- Following field is new in 3.0 - /** - * An optional array of additional text edits that are applied when - * selecting this completion. Edits must not overlap with the main edit - * nor with themselves. - */ - additionalTextEdits?: TextEdit[]; - -- Following field is new in 3.0 - /** - * An optional command that is executed *after* inserting this completion. *Note* that - * additional modifications to the current document should be described with the - * additionalTextEdits-property. - */ - - command?: Command; - /** - * An data entry field that is preserved on a completion item between - * a completion and a completion resolve request. - */ - - data?: any -} - -Where CompletionItemKind is defined as follows: - -/** - * The kind of a completion entry. - */ -enum CompletionItemKind { - Text = 1, - Method = 2, - Function = 3, - Constructor = 4, - Field = 5, - Variable = 6, - Class = 7, - Interface = 8, - Module = 9, - Property = 10, - Unit = 11, - Value = 12, - Enum = 13, - Keyword = 14, - Snippet = 15, - Color = 16, - File = 17, - Reference = 18 -} - - error: code and message set in case an exception happens during the completion request. --} +deriveJSON lspOptions ''CompletionClientCapabilities -- ------------------------------------- @@ -392,20 +266,15 @@ data CompletionItem = deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CompletionItem -data CompletionListType = - CompletionListType - { _isIncomplete :: Bool - , _items :: List CompletionItem +-- | Represents a collection of 'CompletionItem's to be presented in the editor. +data CompletionList = + CompletionList + { _isIncomplete :: Bool -- ^ This list it not complete. Further typing + -- should result in recomputing this list. + , _items :: List CompletionItem -- ^ The completion items. } deriving (Read,Show,Eq) -deriveJSON lspOptions ''CompletionListType - -data CompletionResponseResult - = CompletionList CompletionListType - | Completions (List CompletionItem) - deriving (Read,Show,Eq) - -deriveJSON defaultOptions { fieldLabelModifier = rdrop (length ("CompletionResponseResult"::String)), sumEncoding = UntaggedValue } ''CompletionResponseResult +deriveJSON lspOptions ''CompletionList -- | How a completion was triggered data CompletionTriggerKind = -- | Completion was triggered by typing an identifier (24x7 code @@ -433,6 +302,20 @@ instance A.FromJSON CompletionTriggerKind where parseJSON (A.Number x) = pure (CtUnknown x) parseJSON _ = mempty +makeExtendingDatatype "CompletionOptions" [''WorkDoneProgressOptions] + [ ("_triggerCharacters", [t| Maybe [String] |]) + , ("_allCommitCharacters", [t| Maybe [String] |]) + , ("_resolveProvider", [t| Maybe Bool|]) + ] +deriveJSON lspOptions ''CompletionOptions + +makeExtendingDatatype "CompletionRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''CompletionOptions + ] + [] +deriveJSON lspOptions ''CompletionRegistrationOptions + data CompletionContext = CompletionContext { _triggerKind :: CompletionTriggerKind -- ^ How the completion was triggered. @@ -444,112 +327,11 @@ data CompletionContext = deriveJSON lspOptions ''CompletionContext -data CompletionParams = - CompletionParams - { _textDocument :: TextDocumentIdentifier -- ^ The text document. - , _position :: Position -- ^ The position inside the text document. - , _context :: Maybe CompletionContext - -- ^ The completion context. This is only available if the client specifies - -- to send this using `ClientCapabilities.textDocument.completion.contextSupport === true` - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } - deriving (Read, Show, Eq) - +makeExtendingDatatype "CompletionParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + , ''PartialResultParams + ] + [ ("_context", [t| CompletionContext |]) ] deriveJSON lspOptions ''CompletionParams --- ------------------------------------- -{- -New in 3.0 ------------ -Registration Options: CompletionRegistrationOptions options defined as follows: - -export interface CompletionRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * The characters that trigger completion automatically. - */ - triggerCharacters?: string[]; - - /** - * The server provides support to resolve additional - * information for a completion item. - */ - resolveProvider?: boolean; -} --} - -data CompletionRegistrationOptions = - CompletionRegistrationOptions - { _documentSelector :: Maybe DocumentSelector - , _triggerCharacters :: Maybe (List String) - , _resolveProvider :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''CompletionRegistrationOptions - --- ------------------------------------- - -{- -/** - * Completion options. - */ -interface CompletionOptions { - /** - * The server provides support to resolve additional information for a completion item. - */ - resolveProvider?: boolean; - - /** - * The characters that trigger completion automatically. - */ - triggerCharacters?: string[]; - - /** - * The list of all possible characters that commit a completion. This field can be used - * if clients don't support individual commmit characters per completion item. See - * `ClientCapabilities.textDocument.completion.completionItem.commitCharactersSupport`. - * - * If a server provides both `allCommitCharacters` and commit characters on an individual - * completion item the once on the completion item win. - * - * @since 3.2.0 - */ - allCommitCharacters?: string[]; -} --} - -data CompletionOptions = - CompletionOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - -- | The server provides support to resolve additional information for a completion item. - , _resolveProvider :: Maybe Bool - -- | The characters that trigger completion automatically. - , _triggerCharacters :: Maybe [String] - -- | The list of all possible characters that commit a completion. This field can be used - -- if clients don't support individual commmit characters per completion item. See - -- `_commitCharactersSupport`. - -- Since LSP 3.2.0 - -- @since 0.18.0.0 - , _allCommitCharacters :: Maybe [String] - } deriving (Read,Show,Eq) - -deriveJSONExtendFields lspOptions ''CompletionOptions ["_workDoneProgressOptions"] - --- --------------------------------------------------------------------- -{- -Completion Item Resolve Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#completion-item-resolve-request - -The request is sent from the client to the server to resolve additional -information for a given completion item. - -Request - - method: 'completionItem/resolve' - params: CompletionItem - -Response - - result: CompletionItem - error: code and message set in case an exception happens during the completion resolve request. --} diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Constants.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Constants.hs deleted file mode 100644 index bd985c175..000000000 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Constants.hs +++ /dev/null @@ -1,17 +0,0 @@ - -module Language.Haskell.LSP.Types.Constants where - -import Data.Aeson.TH - --- --------------------------------------------------------------------- - --- | Standard options for use when generating JSON instances -lspOptions :: Options -lspOptions = defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1 } - -- NOTE: This needs to be in a separate file because of the TH stage restriction - -customModifier :: String -> String -customModifier "_xdata" = "data" -customModifier "_xtype" = "type" -customModifier xs = drop 1 xs - diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index 5b04c774f..16358e573 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -22,9 +22,8 @@ import Data.Scientific (floatingOrInteger) import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.LSP.Types.ClientCapabilities -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Diagnostic -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.Method @@ -127,6 +126,7 @@ data InitializeParams = -- -- @since 0.7.0.0 , _workspaceFolders :: Maybe (List WorkspaceFolder) + , _workDoneToken :: Maybe ProgressToken } deriving (Show, Read, Eq) {-# DEPRECATED _rootPath "Use _rootUri" #-} @@ -994,147 +994,6 @@ data PublishDiagnosticsParams = deriveJSON lspOptions ''PublishDiagnosticsParams --- --------------------------------------------------------------------- -{- -Signature Help Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#signature-help-request - -The signature help request is sent from the client to the server to request -signature information at a given cursor position. - - Changed: In 2.0 the request uses TextDocumentPositionParams with proper - textDocument and position properties. In 1.0 the uri of the referenced text - document was inlined into the params object. - -Request - - method: 'textDocument/signatureHelp' - params: TextDocumentPositionParams - -Response - - result: SignatureHelp defined as follows: - -/** - * Signature help represents the signature of something - * callable. There can be multiple signature but only one - * active and only one active parameter. - */ -interface SignatureHelp { - /** - * One or more signatures. - */ - signatures: SignatureInformation[]; - - /** - * The active signature. - */ - activeSignature?: number; - - /** - * The active parameter of the active signature. - */ - activeParameter?: number; -} - -/** - * Represents the signature of something callable. A signature - * can have a label, like a function-name, a doc-comment, and - * a set of parameters. - */ -interface SignatureInformation { - /** - * The label of this signature. Will be shown in - * the UI. - */ - label: string; - - /** - * The human-readable doc-comment of this signature. Will be shown - * in the UI but can be omitted. - */ - documentation?: string; - - /** - * The parameters of this signature. - */ - parameters?: ParameterInformation[]; -} - -/** - * Represents a parameter of a callable-signature. A parameter can - * have a label and a doc-comment. - */ -interface ParameterInformation { - /** - * The label of this signature. Will be shown in - * the UI. - */ - label: string; - - /** - * The human-readable doc-comment of this signature. Will be shown - * in the UI but can be omitted. - */ - documentation?: string; -} - - error: code and message set in case an exception happens during the - signature help request. --} - - -data ParameterInformation = - ParameterInformation - { _label :: Text - , _documentation :: Maybe Text - } deriving (Read,Show,Eq) -deriveJSON lspOptions ''ParameterInformation - - --- ------------------------------------- - -data SignatureInformation = - SignatureInformation - { _label :: Text - , _documentation :: Maybe Text - , _parameters :: Maybe [ParameterInformation] - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''SignatureInformation - -data SignatureHelp = - SignatureHelp - { _signatures :: List SignatureInformation - , _activeSignature :: Maybe Int -- ^ The active signature - , _activeParameter :: Maybe Int -- ^ The active parameter of the active signature - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''SignatureHelp - --- ------------------------------------- -{- -New in 3.0 ----------- -Registration Options: SignatureHelpRegistrationOptions defined as follows: - -export interface SignatureHelpRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * The characters that trigger signature help - * automatically. - */ - triggerCharacters?: string[]; -} --} - -data SignatureHelpRegistrationOptions = - SignatureHelpRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _signatureHelpOptions :: SignatureHelpOptions - } deriving (Show, Read, Eq) - -deriveJSONExtendFields lspOptions ''SignatureHelpRegistrationOptions ["_textDocumentRegistrationOptions", "_signatureHelpOptions"] -- --------------------------------------------------------------------- {- @@ -1232,11 +1091,9 @@ Response workspace symbol request. -} -data WorkspaceSymbolParams = - WorkspaceSymbolParams - { _query :: Text -- ^ A query string to filter symbols by. Clients may send an empty string here to request all symbols. - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) + +makeExtendingDatatype "WorkspaceSymbolParams" [''WorkDoneProgressParams, ''PartialResultParams] + [("_query", [t| String |])] deriveJSON lspOptions ''WorkspaceSymbolParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs index 3af203ed9..69b63e7a8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs @@ -10,9 +10,9 @@ import Data.Aeson.TH import Data.Scientific import Data.Text import GHC.Generics -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs index 96331b475..bf46ddb60 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs @@ -3,8 +3,8 @@ module Language.Haskell.LSP.Types.DocumentFilter where import Data.Aeson.TH import Data.Text ( Text ) -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs index 8759bb79b..854c7bb57 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs @@ -3,7 +3,6 @@ module Language.Haskell.LSP.Types.DocumentHighlight where import Data.Aeson import Data.Aeson.TH -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Utils diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs index 22a31a7c5..d69c4efc2 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs @@ -5,7 +5,6 @@ module Language.Haskell.LSP.Types.FoldingRange where import qualified Data.Aeson as A import Data.Aeson.TH import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.TextDocument diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs index ff83d90ab..61cc76458 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs @@ -4,7 +4,6 @@ module Language.Haskell.LSP.Types.Formatting where import Data.Aeson.TH import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs index 33ed4219b..cf398294a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs @@ -7,39 +7,34 @@ import Control.Applicative import Data.Aeson import Data.Aeson.TH import Data.Text ( Text ) -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List + +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.MarkupContent import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils --- --------------------------------------------------------------------- -{- -/** - * MarkedString can be used to render human readable text. It is either a markdown string - * or a code-block that provides a language and a code snippet. The language identifier - * is semantically equal to the optional language identifier in fenced code blocks in GitHub - * issues. See https://help.github.com/articles/creating-and-highlighting-code-blocks/#syntax-highlighting - * - * The pair of a language and a value is an equivalent to markdown: - * ```${language} - * ${value} - * ``` - * - * Note that markdown strings will be sanitized - that means html will be escaped. -* @deprecated use MarkupContent instead. -*/ -type MarkedString = string | { language: string; value: string }; +-- ------------------------------------- + +data HoverClientCapabilities = + HoverClientCapabilities + { _dynamicRegistration :: Maybe Bool + , _contentFormat :: Maybe (List MarkupKind) + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''HoverClientCapabilities + +makeExtendingDatatype "HoverOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''HoverOptions - error: code and message set in case an exception happens during the hover - request. +makeExtendingDatatype "HoverRegistrationOptions" [''TextDocumentRegistrationOptions, ''HoverOptions] [] +deriveJSON lspOptions ''HoverRegistrationOptions -Registration Options: TextDocumentRegistrationOptions +makeExtendingDatatype "HoverParams" [''TextDocumentPositionParams, ''WorkDoneProgressParams] [] +deriveJSON lspOptions ''HoverParams --} +-- ------------------------------------- data LanguageString = LanguageString @@ -62,46 +57,6 @@ instance FromJSON MarkedString where parseJSON (String t) = pure $ PlainString t parseJSON o = CodeString <$> parseJSON o --- --------------------------------------------------------------------- -{- -Hover Request - -The hover request is sent from the client to the server to request hover -information at a given text document position. - - Changed: In 2.0 the request uses TextDocumentPositionParams with a proper - textDocument and position property. In 1.0 the uri of the referenced text - document was inlined into the params object. - -Request - - method: 'textDocument/hover' - params: TextDocumentPositionParams - -Response - - result: Hover | null defined as follows: - - -/** - * The result of a hover request. - */ -interface Hover { - /** - * The hover's content - */ - contents: MarkedString | MarkedString[] | MarkupContent; - - /** - * An optional range is a range inside a text document - * that is used to visualize a hover, e.g. by changing the background color. - */ - range?: Range; -} - --} - - -- ------------------------------------- data HoverContents = @@ -147,22 +102,3 @@ data Hover = } deriving (Read,Show,Eq) deriveJSON lspOptions ''Hover - -data HoverOptions = - HoverOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) - -deriveJSONExtendFields lspOptions ''HoverOptions ["_workDoneProgressOptions"] - -data HoverRegistrationOptions = - HoverRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _hoverOptions :: HoverOptions - } deriving (Read,Show,Eq) - -deriveJSONExtendFields lspOptions ''HoverRegistrationOptions ["_textDocumentRegistrationOptions", "_hoverOptions"] - --- TODO: derive json instances for this --- makeExtendingDatatype "HoverParams" [''TextDocumentPositionParams, ''WorkDoneProgressParams] - -- [] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index eb34daad5..662686483 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -26,6 +26,7 @@ import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Registration import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument @@ -35,6 +36,8 @@ import Language.Haskell.LSP.Types.WorkspaceFolders import Language.Haskell.LSP.Types.Message import Control.Lens.TH +-- TODO: This is out of date and very unmantainable, use TH to call all these!! + -- client capabilities makeFieldsNoPrefix ''WorkspaceEditClientCapabilities makeFieldsNoPrefix ''DidChangeConfigurationClientCapabilities @@ -49,7 +52,8 @@ makeFieldsNoPrefix ''CompletionItemClientCapabilities makeFieldsNoPrefix ''CompletionItemKindClientCapabilities makeFieldsNoPrefix ''CompletionClientCapabilities makeFieldsNoPrefix ''HoverClientCapabilities -makeFieldsNoPrefix ''SignatureInformationClientCapabilities +makeFieldsNoPrefix ''SignatureHelpSignatureInformation +makeFieldsNoPrefix ''SignatureHelpParameterInformation makeFieldsNoPrefix ''SignatureHelpClientCapabilities makeFieldsNoPrefix ''ReferencesClientCapabilities makeFieldsNoPrefix ''DocumentHighlightClientCapabilities @@ -147,7 +151,7 @@ makeFieldsNoPrefix ''Location -- Completion makeFieldsNoPrefix ''CompletionItem makeFieldsNoPrefix ''CompletionContext -makeFieldsNoPrefix ''CompletionListType +makeFieldsNoPrefix ''CompletionList makeFieldsNoPrefix ''CompletionParams makeFieldsNoPrefix ''CompletionRegistrationOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/List.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/List.hs deleted file mode 100644 index 1217da210..000000000 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/List.hs +++ /dev/null @@ -1,31 +0,0 @@ --- Need to split these types out into a separate module since --- ClientCapabilities also depends on them -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveGeneric #-} -module Language.Haskell.LSP.Types.List where - -import Control.DeepSeq -import qualified Data.Aeson as A -import Data.Aeson.Types -import GHC.Generics - --- | This data type is used to host a FromJSON instance for the encoding used by --- elisp, where an empty list shows up as "null" -newtype List a = List [a] - deriving (Show,Read,Eq,Ord,Monoid,Functor,Foldable,Traversable,Generic) - -instance NFData a => NFData (List a) - -instance (A.ToJSON a) => A.ToJSON (List a) where - toJSON (List ls) = toJSON ls - -instance (A.FromJSON a) => A.FromJSON (List a) where - parseJSON A.Null = return (List []) - parseJSON v = List <$> parseJSON v - -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup (List a) where - (<>) = mappend -#endif diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs index 7f38e8ffb..ba62a7d10 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs @@ -5,8 +5,8 @@ module Language.Haskell.LSP.Types.Location where import Control.DeepSeq import Data.Aeson.TH import GHC.Generics -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- @@ -103,4 +103,4 @@ deriveJSON lspOptions ''Location -- | A helper function for creating ranges. -- prop> mkRange l c l' c' = Range (Position l c) (Position l' c') mkRange :: Int -> Int -> Int -> Int -> Range -mkRange l c l' c' = Range (Position l c) (Position l' c') \ No newline at end of file +mkRange l c l' c' = Range (Position l c) (Position l' c') diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs index 7a6e1c51a..f50fc4e90 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs @@ -14,7 +14,7 @@ import Data.Aeson import Data.Aeson.TH import Data.Monoid ((<>)) import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Utils {- /** diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index c761e3760..1c4bd3152 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -22,14 +22,13 @@ import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color -import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover -import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.Method @@ -37,8 +36,10 @@ import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Registration import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders @@ -144,11 +145,11 @@ type family ResponseParams (m :: Method p Request) :: Type where -- Sync/Document state ResponseParams TextDocumentWillSaveWaitUntil = List TextEdit -- Completion - ResponseParams TextDocumentCompletion = CompletionResponseResult + ResponseParams TextDocumentCompletion = Maybe (List CompletionItem |? CompletionList) ResponseParams CompletionItemResolve = CompletionItem -- Language Queries ResponseParams TextDocumentHover = Maybe Hover - ResponseParams TextDocumentSignatureHelp = SignatureHelp + ResponseParams TextDocumentSignatureHelp = Maybe SignatureHelp ResponseParams TextDocumentDefinition = LocationResponseParams ResponseParams TextDocumentTypeDefinition = LocationResponseParams ResponseParams TextDocumentImplementation = LocationResponseParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs index 5c581a300..c0646ece6 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs @@ -12,7 +12,7 @@ import qualified Data.Aeson as A import Data.Aeson.TH import Data.Maybe (catMaybes) import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Utils -- | A token used to report progress back or return partial results for a -- specific request. diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs index 961323053..9734ab057 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs @@ -1,48 +1,21 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} +-- | Find References Request +-- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#textDocument_references module Language.Haskell.LSP.Types.References where import Data.Aeson.TH -import Language.Haskell.LSP.Types.Constants + import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Utils -{- -Find References Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#find-references-request - -The references request is sent from the client to the server to resolve -project-wide references for the symbol denoted by the given text document -position. - - Changed: In 2.0 the request uses TextDocumentPositionParams with proper - textDocument and position properties. In 1.0 the uri of the referenced text - document was inlined into the params object. - -Request - - method: 'textDocument/references' - params: ReferenceParams defined as follows: - -interface ReferenceParams extends TextDocumentPositionParams { - context: ReferenceContext -} +data ReferencesClientCapabilities = + ReferencesClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) -interface ReferenceContext { - /** - * Include the declaration of the current symbol. - */ - includeDeclaration: boolean; -} - -Response: - - result: Location[] - error: code and message set in case an exception happens during the - reference request. --} +$(deriveJSON lspOptions ''ReferencesClientCapabilities) data ReferenceContext = ReferenceContext @@ -52,32 +25,20 @@ data ReferenceContext = deriveJSON lspOptions ''ReferenceContext -data ReferenceParams = - ReferenceParams - { _textDocumentPositionParams :: TextDocumentPositionParams - , _workDoneProgressParams :: WorkDoneProgressParams - , _partialResultParams :: PartialResultParams - , _context :: ReferenceContext - } deriving (Read,Show,Eq) +makeExtendingDatatype "ReferenceOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''ReferenceOptions -deriveJSONExtendFields lspOptions ''ReferenceParams - [ "_textDocumentPositionParams" - , "_workDoneProgressParams" - , "_partialResultParams" +makeExtendingDatatype "ReferenceRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''ReferenceOptions ] + [] +deriveJSON lspOptions ''ReferenceRegistrationOptions -data ReferenceOptions = - ReferenceOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''ReferenceOptions ["_workDoneProgressOptions"] - -data ReferenceRegistrationOptions = - ReferenceRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _referenceOptions :: ReferenceOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''ReferenceRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_referenceOptions" +makeExtendingDatatype "ReferenceParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + , ''PartialResultParams ] + [("_context", [t| ReferenceContext |])] +deriveJSON lspOptions ''ReferenceParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index ca90886ab..edb82071a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -33,17 +33,17 @@ import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Completion -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs index 2a2943288..039f80c32 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs @@ -5,7 +5,7 @@ module Language.Haskell.LSP.Types.Rename where import Data.Aeson.TH import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants + import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Progress diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 45ec63664..96aad65e3 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -12,8 +12,8 @@ import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion -import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting @@ -21,25 +21,12 @@ import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils --- | A terser, isomorphic data type for 'Either', that does not get tagged when --- converting to and from JSON. -data a |? b = L a - | R b - deriving (Read,Show,Eq) -infixr |? - -instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where - toJSON (L x) = toJSON x - toJSON (R x) = toJSON x - -instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where - parseJSON v = L <$> parseJSON v <|> R <$> parseJSON v - -- --------------------------------------------------------------------- {- The server can signal the following capabilities: @@ -304,42 +291,6 @@ instance ToJSON TDS where toJSON (TDSOptions x) = toJSON x toJSON (TDSKind x) = toJSON x -{- -/** - * Signature help options. - */ -interface SignatureHelpOptions { - /** - * The characters that trigger signature help automatically. - */ - triggerCharacters?: string[]; - /** - * List of characters that re-trigger signature help. - * - * These trigger characters are only active when signature help is already showing. All trigger characters - * are also counted as re-trigger characters. - * - * @since 3.15.0 - */ --} - -data SignatureHelpOptions = - SignatureHelpOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - , -- | The characters that trigger signature help automatically. - _triggerCharacters :: Maybe [String] - - -- | List of characters that re-trigger signature help. - -- These trigger characters are only active when signature help is already showing. All trigger characters - -- are also counted as re-trigger characters. - -- - -- Since LSP 3.15.0 - -- @since 0.18.0.0 - , _retriggerCharacters :: Maybe [String] - } deriving (Read,Show,Eq) - -deriveJSONExtendFields lspOptions ''SignatureHelpOptions ["_workDoneProgressOptions"] - -- --------------------------------------------------------------------- data DefinitionOptions = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/SignatureHelp.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/SignatureHelp.hs new file mode 100644 index 000000000..fdcd4d350 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/SignatureHelp.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Signature Help Request +-- https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#signature-help-request +module Language.Haskell.LSP.Types.SignatureHelp where + +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.MarkupContent +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +-- ------------------------------------- + +data SignatureHelpParameterInformation = + SignatureHelpParameterInformation + { -- | The client supports processing label offsets instead of a simple + -- label string. + -- + -- @since 3.14.0 + _labelOffsetSupport :: Maybe Bool + } + deriving (Read, Show, Eq) +deriveJSON lspOptions ''SignatureHelpParameterInformation + +data SignatureHelpSignatureInformation = + SignatureHelpSignatureInformation + { -- | Client supports the follow content formats for the documentation + -- property. The order describes the preferred format of the client. + _documentationFormat :: Maybe (List MarkupKind) + -- | Client capabilities specific to parameter information. + , _parameterInformation :: Maybe SignatureHelpParameterInformation + } + deriving (Show, Read, Eq) + +deriveJSON lspOptions ''SignatureHelpSignatureInformation + +data SignatureHelpClientCapabilities = + SignatureHelpClientCapabilities + { -- | Whether signature help supports dynamic registration. + _dynamicRegistration :: Maybe Bool + -- | The client supports the following 'SignatureInformation' + -- specific properties. + , _signatureInformation :: Maybe SignatureHelpSignatureInformation + -- | The client supports to send additional context information for a + -- @textDocument/signatureHelp@ request. A client that opts into + -- contextSupport will also support the '_retriggerCharacters' on + -- 'SignatureHelpOptions'. + -- + -- @since 3.15.0 + , _contextSupport :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''SignatureHelpClientCapabilities + +-- ------------------------------------- + +makeExtendingDatatype "SignatureHelpOptions" [''WorkDoneProgressOptions] + [ ("_triggerCharacters", [t| Maybe (List String) |]) + , ("_retriggerCharacters", [t| Maybe (List String) |]) + ] +deriveJSON lspOptions ''SignatureHelpOptions + +makeExtendingDatatype "SignatureHelpRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''SignatureHelpOptions + ] [] +deriveJSON lspOptions ''SignatureHelpRegistrationOptions + +-- ------------------------------------- + +data ParameterInformation = + ParameterInformation + { _label :: Text + , _documentation :: Maybe Text + } deriving (Read,Show,Eq) +deriveJSON lspOptions ''ParameterInformation + +-- ------------------------------------- + +data SignatureInformation = + SignatureInformation + { _label :: Text + , _documentation :: Maybe Text + , _parameters :: Maybe (List ParameterInformation) + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''SignatureInformation + +data SignatureHelp = + SignatureHelp + { _signatures :: List SignatureInformation + , _activeSignature :: Maybe Int -- ^ The active signature + , _activeParameter :: Maybe Int -- ^ The active parameter of the active signature + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''SignatureHelp + +-- ------------------------------------- + +data SignatureHelpTriggerKind = SHTKInvoked + | SHTKTriggerCharacter + | SHTKContentChange + deriving (Read,Show,Eq) + +instance ToJSON SignatureHelpTriggerKind where + toJSON SHTKInvoked = Number 1 + toJSON SHTKTriggerCharacter = Number 2 + toJSON SHTKContentChange = Number 3 + +instance FromJSON SignatureHelpTriggerKind where + parseJSON (Number 1) = pure SHTKInvoked + parseJSON (Number 2) = pure SHTKTriggerCharacter + parseJSON (Number 3) = pure SHTKContentChange + parseJSON _ = mempty + +-- | Additional information about the context in which a signature help request +-- was triggered. +data SignatureHelpContext = + SignatureHelpContext + { -- | Action that caused signature help to be triggered. + _triggerKind :: SignatureHelpTriggerKind + -- | Character that caused signature help to be triggered. This is + -- undefined when @triggerKind !== + -- SignatureHelpTriggerKind.TriggerCharacter@ + , _triggerCharacter :: Maybe String + -- | 'True' if signature help was already showing when it was triggered. + -- + -- Retriggers occur when the signature help is already active and can be + -- caused by actions such as typing a trigger character, a cursor move, or + -- document content changes. + , _isRetrigger :: Bool + -- | The currently active 'SignatureHelp'. + -- + -- The '_activeSignatureHelp' has its @SignatureHelp.activeSignature@ + -- field updated based on the user navigating through available + -- signatures. + , _activeSignatureHelp :: Maybe SignatureHelp + } + deriving (Read,Show,Eq) +deriveJSON lspOptions ''SignatureHelpContext + +makeExtendingDatatype "SignatureHelpParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + ] + [ ("_context", [t| Maybe SignatureHelpContext |]) + ] +deriveJSON lspOptions ''SignatureHelpParams + + diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs index e44095ccc..978d7a947 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/StaticRegistrationOptions.hs @@ -4,7 +4,7 @@ module Language.Haskell.LSP.Types.StaticRegistrationOptions where import Data.Aeson.TH import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Utils data StaticRegistrationOptions = StaticRegistrationOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs index f53165067..0b4ebb427 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs @@ -7,9 +7,9 @@ import Data.Aeson import Data.Aeson.TH import Data.Scientific import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants + import Language.Haskell.LSP.Types.TextDocument -import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Utils diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs index 3e163589f..d923b71cb 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs @@ -4,11 +4,11 @@ module Language.Haskell.LSP.Types.TextDocument where import Data.Aeson.TH import Data.Text ( Text ) -import Language.Haskell.LSP.Types.Constants + import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.Location -import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs index f2a55dc15..f11ae93e1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs @@ -1,21 +1,23 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} +-- | Internal helpers for generating definitions module Language.Haskell.LSP.Types.Utils ( rdrop , makeSingletonFromJSON , deriveJSONExtendFields , makeRegHelper , makeExtendingDatatype + , lspOptions + , customModifier ) where -import qualified Data.HashMap.Strict as HM import Language.Haskell.TH import Data.Aeson +import qualified Data.HashMap.Strict as HM import Data.String import Control.Monad import Data.List (foldl', (\\)) -import Data.Maybe (fromJust) -- --------------------------------------------------------------------- @@ -169,17 +171,27 @@ makeRegHelper regOptTypeName = do -> x |] return [typSig, fun] -makeExtendingDatatype :: String -> [Name] -> [(String, Name)] -> DecsQ +-- | Generates a datatype +makeExtendingDatatype :: String -> [Name] -> [(String, TypeQ)] -> DecsQ makeExtendingDatatype datatypeNameStr extends fields = do extendFields <- fmap concat $ forM extends $ \e -> do - reify e >>= runIO . print TyConI (DataD _ _ _ _ [RecC _ eFields] _) <- reify e return eFields let datatypeName = mkName datatypeNameStr insts = [[t| Read |], [t| Show |], [t| Eq |]] constructor = recC datatypeName combinedFields - userFields = flip map fields $ \(s, n) -> do - varBangType (mkName s) (bangType (bang noSourceUnpackedness noSourceStrictness) (conT n)) + userFields = flip map fields $ \(s, typ) -> do + varBangType (mkName s) (bangType (bang noSourceUnpackedness noSourceStrictness) typ) combinedFields = (map pure extendFields) <> userFields derivs = [derivClause Nothing insts] (\a -> [a]) <$> dataD (cxt []) datatypeName [] Nothing [constructor] derivs + +-- | Standard options for use when generating JSON instances +lspOptions :: Options +lspOptions = defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1 } + -- NOTE: This needs to be in a separate file because of the TH stage restriction + +customModifier :: String -> String +customModifier "_xdata" = "data" +customModifier "_xtype" = "type" +customModifier xs = drop 1 xs diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs index f8bd91585..eb4b87fd3 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs @@ -7,7 +7,7 @@ module Language.Haskell.LSP.Types.Window where import qualified Data.Aeson as A import Data.Aeson.TH import Data.Text (Text) -import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs index 5c21bc286..7d621c2b4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs @@ -9,10 +9,11 @@ import qualified Data.HashMap.Strict as H import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List + +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs index bbcc141a7..4a5c71aab 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs @@ -4,8 +4,9 @@ module Language.Haskell.LSP.Types.WorkspaceFolders where import Data.Aeson.TH import Data.Text ( Text ) -import Language.Haskell.LSP.Types.Constants -import Language.Haskell.LSP.Types.List + +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Utils {- Workspace folders request (:arrow_right_hook:) From 04bcc0eedbc6f2fbe118c88741278d92cbe7747c Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 12 Aug 2020 17:05:25 +0100 Subject: [PATCH 05/63] Implement go to declaration --- haskell-lsp-types/haskell-lsp-types.cabal | 1 + .../src/Language/Haskell/LSP/Types.hs | 2 + .../Language/Haskell/LSP/Types/Declaration.hs | 39 +++++++++++++++++++ .../Language/Haskell/LSP/Types/Location.hs | 23 +++++++++++ .../src/Language/Haskell/LSP/Types/Message.hs | 8 +++- .../src/Language/Haskell/LSP/Types/Method.hs | 4 ++ .../Haskell/LSP/Types/Registration.hs | 4 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 5 +++ 8 files changed, 82 insertions(+), 4 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Declaration.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index 8af21cd61..a9909cff1 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -29,6 +29,7 @@ library , Language.Haskell.LSP.Types.Common , Language.Haskell.LSP.Types.Completion , Language.Haskell.LSP.Types.DataTypesJSON + , Language.Haskell.LSP.Types.Declaration , Language.Haskell.LSP.Types.Diagnostic , Language.Haskell.LSP.Types.DocumentFilter , Language.Haskell.LSP.Types.DocumentHighlight diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index e1a2fe081..cacdbb128 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -6,6 +6,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Command , module Language.Haskell.LSP.Types.Common , module Language.Haskell.LSP.Types.Completion + , module Language.Haskell.LSP.Types.Declaration , module Language.Haskell.LSP.Types.Diagnostic , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.Empty @@ -38,6 +39,7 @@ import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.Empty diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Declaration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Declaration.hs new file mode 100644 index 000000000..7fcd88953 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Declaration.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.LSP.Types.Declaration where + +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.StaticRegistrationOptions +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +data DeclarationClientCapabilities = + DeclarationClientCapabilities + { -- | Whether declaration supports dynamic registration. If this is set to 'true' + -- the client supports the new 'DeclarationRegistrationOptions' return value + -- for the corresponding server capability as well. + _dynamicRegistration :: Maybe Bool + -- | The client supports additional metadata in the form of declaration links. + , _linkSupport :: Maybe Bool + } + deriving (Read, Show, Eq) +deriveJSON lspOptions ''DeclarationClientCapabilities + +makeExtendingDatatype "DeclarationOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''DeclarationOptions + +makeExtendingDatatype "DeclarationRegistrationOptions" + [ ''DeclarationOptions + , ''TextDocumentRegistrationOptions + , ''StaticRegistrationOptions + ] [] +deriveJSON lspOptions ''DeclarationRegistrationOptions + +makeExtendingDatatype "DeclarationParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + , ''PartialResultParams + ] [] +deriveJSON lspOptions ''DeclarationParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs index ba62a7d10..eb4b1f4aa 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs @@ -100,6 +100,29 @@ deriveJSON lspOptions ''Location -- --------------------------------------------------------------------- +-- | Represents a link between a source and a target location. +data LocationLink = + LocationLink + { -- | Span of the origin of this link. + -- Used as the underlined span for mouse interaction. Defaults to the word + -- range at the mouse position. + _originSelectionRange :: Maybe Range + -- | The target resource identifier of this link. + , _targetUri :: Uri + -- | The full target range of this link. If the target for example is a + -- symbol then target range is the range enclosing this symbol not including + -- leading/trailing whitespace but everything else like comments. This + -- information is typically used to highlight the range in the editor. + , _targetRange :: Range + -- | The range that should be selected and revealed when this link is being + -- followed, e.g the name of a function. Must be contained by the the + -- 'targetRange'. See also @DocumentSymbol._range@ + , _targetSelectionRange :: Range + } deriving (Read, Show, Eq) +deriveJSON lspOptions ''LocationLink + +-- --------------------------------------------------------------------- + -- | A helper function for creating ranges. -- prop> mkRange l c l' c' = Range (Position l c) (Position l' c') mkRange :: Int -> Int -> Int -> Int -> Range diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 1c4bd3152..0b6e091fb 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -24,6 +24,7 @@ import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange @@ -85,8 +86,9 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams TextDocumentCompletion = CompletionParams MessageParams CompletionItemResolve = CompletionItem -- Language Queries - MessageParams TextDocumentHover = TextDocumentPositionParams - MessageParams TextDocumentSignatureHelp = TextDocumentPositionParams + MessageParams TextDocumentHover = HoverParams + MessageParams TextDocumentSignatureHelp = SignatureHelpParams + MessageParams TextDocumentDeclaration = DeclarationParams MessageParams TextDocumentDefinition = TextDocumentPositionParams MessageParams TextDocumentTypeDefinition = TextDocumentPositionParams MessageParams TextDocumentImplementation = TextDocumentPositionParams @@ -150,6 +152,7 @@ type family ResponseParams (m :: Method p Request) :: Type where -- Language Queries ResponseParams TextDocumentHover = Maybe Hover ResponseParams TextDocumentSignatureHelp = Maybe SignatureHelp + ResponseParams TextDocumentDeclaration = Maybe (Location |? List Location |? LocationLink) ResponseParams TextDocumentDefinition = LocationResponseParams ResponseParams TextDocumentTypeDefinition = LocationResponseParams ResponseParams TextDocumentImplementation = LocationResponseParams @@ -633,6 +636,7 @@ splitClientMethod STextDocumentCompletion = IsClientReq splitClientMethod SCompletionItemResolve = IsClientReq splitClientMethod STextDocumentHover = IsClientReq splitClientMethod STextDocumentSignatureHelp = IsClientReq +splitClientMethod STextDocumentDeclaration = IsClientReq splitClientMethod STextDocumentDefinition = IsClientReq splitClientMethod STextDocumentTypeDefinition = IsClientReq splitClientMethod STextDocumentImplementation = IsClientReq diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index 16eac787b..86190688e 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -50,6 +50,7 @@ data Method (p :: Provenance) (t :: MethodType) where -- LanguageQueries TextDocumentHover :: Method FromClient Request TextDocumentSignatureHelp :: Method FromClient Request + TextDocumentDeclaration :: Method FromClient Request TextDocumentDefinition :: Method FromClient Request TextDocumentTypeDefinition :: Method FromClient Request TextDocumentImplementation :: Method FromClient Request @@ -121,6 +122,7 @@ data SMethod (m :: Method p t) where SCompletionItemResolve :: SMethod CompletionItemResolve STextDocumentHover :: SMethod TextDocumentHover STextDocumentSignatureHelp :: SMethod TextDocumentSignatureHelp + STextDocumentDeclaration :: SMethod TextDocumentDeclaration STextDocumentDefinition :: SMethod TextDocumentDefinition STextDocumentTypeDefinition :: SMethod TextDocumentTypeDefinition STextDocumentImplementation :: SMethod TextDocumentImplementation @@ -238,6 +240,7 @@ instance FromJSON SomeClientMethod where parseJSON (A.String "completionItem/resolve") = pure $ SomeClientMethod SCompletionItemResolve parseJSON (A.String "textDocument/hover") = pure $ SomeClientMethod STextDocumentHover parseJSON (A.String "textDocument/signatureHelp") = pure $ SomeClientMethod STextDocumentSignatureHelp + parseJSON (A.String "textDocument/declaration") = pure $ SomeClientMethod STextDocumentDeclaration parseJSON (A.String "textDocument/definition") = pure $ SomeClientMethod STextDocumentDefinition parseJSON (A.String "textDocument/typeDefinition") = pure $ SomeClientMethod STextDocumentTypeDefinition parseJSON (A.String "textDocument/implementation") = pure $ SomeClientMethod STextDocumentImplementation @@ -332,6 +335,7 @@ instance A.ToJSON (SMethod m) where toJSON STextDocumentReferences = A.String "textDocument/references" toJSON STextDocumentDocumentHighlight = A.String "textDocument/documentHighlight" toJSON STextDocumentDocumentSymbol = A.String "textDocument/documentSymbol" + toJSON STextDocumentDeclaration = A.String "textDocument/declaration" toJSON STextDocumentDefinition = A.String "textDocument/definition" toJSON STextDocumentTypeDefinition = A.String "textDocument/typeDefinition" toJSON STextDocumentImplementation = A.String "textDocument/implementation" diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index edb82071a..fe90dc953 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -34,6 +34,7 @@ import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON +import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange @@ -115,8 +116,7 @@ type family RegistrationOptions (m :: Method FromClient t) :: Type where RegistrationOptions TextDocumentCompletion = CompletionRegistrationOptions RegistrationOptions TextDocumentHover = HoverRegistrationOptions RegistrationOptions TextDocumentSignatureHelp = SignatureHelpRegistrationOptions - -- TODO: Add me once textDocument/declaration is implemented - -- RegistrationOptions TextDocumentDeclaration = DeclarationRegistrationOptions + RegistrationOptions TextDocumentDeclaration = DeclarationRegistrationOptions RegistrationOptions TextDocumentDefinition = DefinitionRegistrationOptions RegistrationOptions TextDocumentTypeDefinition = TypeDefinitionRegistrationOptions RegistrationOptions TextDocumentImplementation = ImplementationRegistrationOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 96aad65e3..77461ad21 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -14,6 +14,7 @@ import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting @@ -462,6 +463,10 @@ data ServerCapabilities = , _completionProvider :: Maybe CompletionOptions -- | The server provides signature help support. , _signatureHelpProvider :: Maybe SignatureHelpOptions + -- | The server provides go to declaration support. + -- + -- Since LSP 3.14.0 + , _declarationProvider :: Maybe (Bool |? DeclarationOptions |? DeclarationRegistrationOptions) -- | The server provides goto definition support. , _definitionProvider :: Maybe (Bool |? DefinitionOptions) -- | The server provides Goto Type Definition support. Since LSP 3.6 From 52fd481e93b0a516e7619d4bd7a291b86e2b7dd2 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 12 Aug 2020 17:22:04 +0100 Subject: [PATCH 06/63] Update definition request --- haskell-lsp-types/haskell-lsp-types.cabal | 2 +- .../src/Language/Haskell/LSP/Types.hs | 2 + .../Haskell/LSP/Types/Capabilities.hs | 3 +- .../Haskell/LSP/Types/ClientCapabilities.hs | 76 +++++++++---------- .../Language/Haskell/LSP/Types/Definition.hs | 36 +++++++++ .../src/Language/Haskell/LSP/Types/Lens.hs | 1 + .../src/Language/Haskell/LSP/Types/Message.hs | 7 +- .../Haskell/LSP/Types/Registration.hs | 1 + .../Haskell/LSP/Types/ServerCapabilities.hs | 23 +----- 9 files changed, 85 insertions(+), 66 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Definition.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index a9909cff1..1732b4ca2 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -30,6 +30,7 @@ library , Language.Haskell.LSP.Types.Completion , Language.Haskell.LSP.Types.DataTypesJSON , Language.Haskell.LSP.Types.Declaration + , Language.Haskell.LSP.Types.Definition , Language.Haskell.LSP.Types.Diagnostic , Language.Haskell.LSP.Types.DocumentFilter , Language.Haskell.LSP.Types.DocumentHighlight @@ -59,7 +60,6 @@ library , Language.Haskell.LSP.Types.WorkspaceFolders -- other-extensions: ghc-options: -Wall - -- ghc-options: -Werror build-depends: base >= 4.9 && < 4.15 , aeson >=1.2.2.0 , binary diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index cacdbb128..00d5b70a0 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -7,6 +7,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Common , module Language.Haskell.LSP.Types.Completion , module Language.Haskell.LSP.Types.Declaration + , module Language.Haskell.LSP.Types.Definition , module Language.Haskell.LSP.Types.Diagnostic , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.Empty @@ -40,6 +41,7 @@ import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration +import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.Empty diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 7a12d89b5..9f5e5997d 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -97,7 +97,8 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (Just (FormattingClientCapabilities (Just True))) (Just (RangeFormattingClientCapabilities dynamicReg)) (Just (OnTypeFormattingClientCapabilities dynamicReg)) - (Just (DefinitionClientCapabilities dynamicReg)) + (Just (DeclarationClientCapabilities dynamicReg (Just True))) + (Just (DefinitionClientCapabilities dynamicReg (Just True))) (since 3 6 (TypeDefinitionClientCapabilities dynamicReg)) (since 3 6 (ImplementationClientCapabilities dynamicReg)) (Just codeActionCapability) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 96b82bb4d..2205e4956 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -9,6 +9,8 @@ import Data.Default import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Diagnostic +import Language.Haskell.LSP.Types.Declaration +import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.SignatureHelp @@ -567,13 +569,13 @@ export interface TextDocumentClientCapabilities { * Whether rename supports dynamic registration. */ dynamicRegistration?: boolean; - /** - * The client supports testing for validity of rename operations - * before execution. + /** + * The client supports testing for validity of rename operations + * before execution. * * Since 3.12.0 - */ - prepareSupport?: boolean; + */ + prepareSupport?: boolean; }; /** @@ -587,28 +589,28 @@ export interface TextDocumentClientCapabilities { }; /** - * Capabilities specific to `textDocument/foldingRange` requests. - * - * Since 3.10.0 - */ - foldingRange?: { - /** - * Whether implementation supports dynamic registration for folding range providers. If this is set to `true` - * the client supports the new `(FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions)` - * return value for the corresponding server capability as well. - */ - dynamicRegistration?: boolean; - /** - * The maximum number of folding ranges that the client prefers to receive per document. The value serves as a - * hint, servers are free to follow the limit. - */ - rangeLimit?: number; - /** - * If set, the client signals that it only supports folding complete lines. If set, client will - * ignore specified `startCharacter` and `endCharacter` properties in a FoldingRange. - */ - lineFoldingOnly?: boolean; - }; + * Capabilities specific to `textDocument/foldingRange` requests. + * + * Since 3.10.0 + */ + foldingRange?: { + /** + * Whether implementation supports dynamic registration for folding range providers. If this is set to `true` + * the client supports the new `(FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions)` + * return value for the corresponding server capability as well. + */ + dynamicRegistration?: boolean; + /** + * The maximum number of folding ranges that the client prefers to receive per document. The value serves as a + * hint, servers are free to follow the limit. + */ + rangeLimit?: number; + /** + * If set, the client signals that it only supports folding complete lines. If set, client will + * ignore specified `startCharacter` and `endCharacter` properties in a FoldingRange. + */ + lineFoldingOnly?: boolean; + }; } -} @@ -707,15 +709,6 @@ $(deriveJSON lspOptions ''OnTypeFormattingClientCapabilities) -- ------------------------------------- -data DefinitionClientCapabilities = - DefinitionClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''DefinitionClientCapabilities) - --- ------------------------------------- - data TypeDefinitionClientCapabilities = TypeDefinitionClientCapabilities { -- | Whether typeDefinition supports dynamic registration. If this is set to `true` @@ -895,6 +888,11 @@ data TextDocumentClientCapabilities = -- | Capabilities specific to the `textDocument/onTypeFormatting` , _onTypeFormatting :: Maybe OnTypeFormattingClientCapabilities + -- | Capabilities specific to the `textDocument/declaration` request. + -- + -- Since LSP 3.14.0 + , _declaration :: Maybe DeclarationClientCapabilities + -- | Capabilities specific to the `textDocument/definition` , _definition :: Maybe DefinitionClientCapabilities @@ -934,7 +932,7 @@ $(deriveJSON lspOptions ''TextDocumentClientCapabilities) instance Default TextDocumentClientCapabilities where def = TextDocumentClientCapabilities def def def def def def def def def def def def def def def def - def def def def + def def def def def -- --------------------------------------------------------------------- @@ -993,8 +991,8 @@ interface ClientCapabilities { /** * Window specific client capabilities. - */ - window?: WindowClientCapabilities; + */ + window?: WindowClientCapabilities; } -} diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Definition.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Definition.hs new file mode 100644 index 000000000..7ae9b2cec --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Definition.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.LSP.Types.Definition where + +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +data DefinitionClientCapabilities = + DefinitionClientCapabilities + { -- | Whether definition supports dynamic registration. + _dynamicRegistration :: Maybe Bool + -- | The client supports additional metadata in the form of definition + -- links. + -- Since LSP 3.14.0 + , _linkSupport :: Maybe Bool + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''DefinitionClientCapabilities + +makeExtendingDatatype "DefinitionOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''DefinitionOptions + +makeExtendingDatatype "DefinitionRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''DefinitionOptions + ] [] +deriveJSON lspOptions ''DefinitionRegistrationOptions + +makeExtendingDatatype "DefinitionParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + , ''PartialResultParams + ] [] +deriveJSON lspOptions ''DefinitionParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 662686483..13c639a44 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -15,6 +15,7 @@ import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON +import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 0b6e091fb..9a60fa453 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -25,6 +25,7 @@ import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration +import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange @@ -89,7 +90,7 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams TextDocumentHover = HoverParams MessageParams TextDocumentSignatureHelp = SignatureHelpParams MessageParams TextDocumentDeclaration = DeclarationParams - MessageParams TextDocumentDefinition = TextDocumentPositionParams + MessageParams TextDocumentDefinition = DefinitionParams MessageParams TextDocumentTypeDefinition = TextDocumentPositionParams MessageParams TextDocumentImplementation = TextDocumentPositionParams MessageParams TextDocumentReferences = ReferenceParams @@ -152,8 +153,8 @@ type family ResponseParams (m :: Method p Request) :: Type where -- Language Queries ResponseParams TextDocumentHover = Maybe Hover ResponseParams TextDocumentSignatureHelp = Maybe SignatureHelp - ResponseParams TextDocumentDeclaration = Maybe (Location |? List Location |? LocationLink) - ResponseParams TextDocumentDefinition = LocationResponseParams + ResponseParams TextDocumentDeclaration = Maybe (Location |? List Location |? List LocationLink) + ResponseParams TextDocumentDefinition = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentTypeDefinition = LocationResponseParams ResponseParams TextDocumentImplementation = LocationResponseParams ResponseParams TextDocumentReferences = List Location diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index fe90dc953..86e52d7b4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -35,6 +35,7 @@ import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Declaration +import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 77461ad21..4513bcca1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -15,6 +15,7 @@ import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration +import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting @@ -294,28 +295,6 @@ instance ToJSON TDS where -- --------------------------------------------------------------------- -data DefinitionOptions = - DefinitionOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } - deriving (Eq,Read,Show) - -deriveJSONExtendFields lspOptions ''DefinitionOptions ["_workDoneProgressOptions"] - -data DefinitionRegistrationOptions = - DefinitionRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _definitionOptions :: DefinitionOptions - } deriving (Read,Show,Eq) - -deriveJSONExtendFields lspOptions ''DefinitionRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_definitionOptions" - ] - - --- --------------------------------------------------------------------- - {- Goto Type Definition Request (:leftwards_arrow_with_hook:) Since version 3.6.0 From dec10f7554cfa879101edd02ebe5a3dfe2a6e1fb Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 12 Aug 2020 17:38:15 +0100 Subject: [PATCH 07/63] Update typeDefinition request --- haskell-lsp-types/haskell-lsp-types.cabal | 1 + .../src/Language/Haskell/LSP/Types.hs | 2 + .../Haskell/LSP/Types/Capabilities.hs | 6 +-- .../Haskell/LSP/Types/ClientCapabilities.hs | 13 +----- .../src/Language/Haskell/LSP/Types/Lens.hs | 1 + .../src/Language/Haskell/LSP/Types/Message.hs | 5 ++- .../Haskell/LSP/Types/Registration.hs | 1 + .../Haskell/LSP/Types/ServerCapabilities.hs | 43 +------------------ .../Language/Haskell/LSP/Types/Synonyms.hs | 3 ++ .../Haskell/LSP/Types/TypeDefinition.hs | 42 ++++++++++++++++++ 10 files changed, 59 insertions(+), 58 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/TypeDefinition.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index 1732b4ca2..668a23472 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -53,6 +53,7 @@ library , Language.Haskell.LSP.Types.Symbol , Language.Haskell.LSP.Types.Synonyms , Language.Haskell.LSP.Types.TextDocument + , Language.Haskell.LSP.Types.TypeDefinition , Language.Haskell.LSP.Types.Uri , Language.Haskell.LSP.Types.Utils , Language.Haskell.LSP.Types.Window diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 00d5b70a0..c8db7bfd5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -27,6 +27,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Symbol , module Language.Haskell.LSP.Types.Synonyms , module Language.Haskell.LSP.Types.TextDocument + , module Language.Haskell.LSP.Types.TypeDefinition , module Language.Haskell.LSP.Types.Uri , module Language.Haskell.LSP.Types.Window , module Language.Haskell.LSP.Types.WorkspaceEdit @@ -62,6 +63,7 @@ import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.Synonyms import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 9f5e5997d..195a20e3e 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -97,9 +97,9 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (Just (FormattingClientCapabilities (Just True))) (Just (RangeFormattingClientCapabilities dynamicReg)) (Just (OnTypeFormattingClientCapabilities dynamicReg)) - (Just (DeclarationClientCapabilities dynamicReg (Just True))) - (Just (DefinitionClientCapabilities dynamicReg (Just True))) - (since 3 6 (TypeDefinitionClientCapabilities dynamicReg)) + (since 3 14 (DeclarationClientCapabilities dynamicReg (Just True))) + (Just (DefinitionClientCapabilities dynamicReg (since 3 14 True))) + (since 3 6 (TypeDefinitionClientCapabilities dynamicReg (since 3 14 True))) (since 3 6 (ImplementationClientCapabilities dynamicReg)) (Just codeActionCapability) (Just (CodeLensClientCapabilities dynamicReg)) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 2205e4956..d5662bf59 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -16,6 +16,7 @@ import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- @@ -707,18 +708,6 @@ data OnTypeFormattingClientCapabilities = $(deriveJSON lspOptions ''OnTypeFormattingClientCapabilities) --- ------------------------------------- - -data TypeDefinitionClientCapabilities = - TypeDefinitionClientCapabilities - { -- | Whether typeDefinition supports dynamic registration. If this is set to `true` - -- the client supports the new `(TextDocumentRegistrationOptions & StaticRegistrationOptions)` - -- return value for the corresponding server capability as well. - _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''TypeDefinitionClientCapabilities) - -- ------------------------------------- -- data ImplementationClientCapabilities = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 13c639a44..69d987e57 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -31,6 +31,7 @@ import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 9a60fa453..80aeb68aa 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -41,6 +41,7 @@ import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit @@ -91,7 +92,7 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams TextDocumentSignatureHelp = SignatureHelpParams MessageParams TextDocumentDeclaration = DeclarationParams MessageParams TextDocumentDefinition = DefinitionParams - MessageParams TextDocumentTypeDefinition = TextDocumentPositionParams + MessageParams TextDocumentTypeDefinition = TypeDefinitionParams MessageParams TextDocumentImplementation = TextDocumentPositionParams MessageParams TextDocumentReferences = ReferenceParams MessageParams TextDocumentDocumentHighlight = TextDocumentPositionParams @@ -155,7 +156,7 @@ type family ResponseParams (m :: Method p Request) :: Type where ResponseParams TextDocumentSignatureHelp = Maybe SignatureHelp ResponseParams TextDocumentDeclaration = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentDefinition = Maybe (Location |? List Location |? List LocationLink) - ResponseParams TextDocumentTypeDefinition = LocationResponseParams + ResponseParams TextDocumentTypeDefinition = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentImplementation = LocationResponseParams ResponseParams TextDocumentReferences = List Location ResponseParams TextDocumentDocumentHighlight = List DocumentHighlight diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index 86e52d7b4..a8eef0873 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -48,6 +48,7 @@ import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 4513bcca1..fe703e467 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -27,6 +27,7 @@ import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- @@ -295,44 +296,6 @@ instance ToJSON TDS where -- --------------------------------------------------------------------- -{- -Goto Type Definition Request (:leftwards_arrow_with_hook:) -Since version 3.6.0 - -The goto type definition request is sent from the client to the server to resolve the type definition location of a symbol at a given text document position. - -Request: - -method: ‘textDocument/typeDefinition’ -params: TextDocumentPositionParams -Response: - -result: Location | Location[] | null -error: code and message set in case an exception happens during the definition request. -Registration Options: TextDocumentRegistrationOptions --} - -data TypeDefinitionOptions = - TypeDefinitionOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''TypeDefinitionOptions ["_workDoneProgressOptions"] - -data TypeDefinitionRegistrationOptions = - TypeDefinitionRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _typeDefinitionOptions :: TypeDefinitionOptions - , _staticRegistrationOptions :: StaticRegistrationOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''TypeDefinitionRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_typeDefinitionOptions" - , "_staticRegistrationOptions" - ] - - --- --------------------------------------------------------------------- - {- Goto Implementation Request (:leftwards_arrow_with_hook:) Since version 3.6.0 @@ -421,7 +384,6 @@ deriveJSON lspOptions ''WorkspaceFoldersServerCapabilities data WorkspaceServerCapabilities = WorkspaceServerCapabilities { -- | The server supports workspace folder. Since LSP 3.6 - -- Since LSP 3.6.0 -- -- @since 0.7.0.0 _workspaceFolders :: Maybe WorkspaceFoldersServerCapabilities @@ -452,8 +414,7 @@ data ServerCapabilities = -- -- @since 0.7.0.0 , _typeDefinitionProvider :: Maybe (Bool |? TypeDefinitionOptions |? TypeDefinitionRegistrationOptions) - -- | The server provides Goto Implementation support. - -- Since LSP 3.6 + -- | The server provides Goto Implementation support. Since LSP 3.6 -- -- @since 0.7.0.0 , _implementationProvider :: Maybe (Bool |? ImplementationOptions |? ImplementationRegistrationOptions) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs index 89f67661c..7e127ff0c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs @@ -103,6 +103,9 @@ type HoverResponse = ResponseMessage TextDocumentHover type SignatureHelpRequest = Message TextDocumentSignatureHelp type SignatureHelpResponse = ResponseMessage TextDocumentSignatureHelp +type DeclarationRequest = Message TextDocumentDeclaration +type DeclarationResponse = ResponseMessage TextDocumentDeclaration + type DefinitionRequest = Message TextDocumentDefinition type DefinitionResponse = ResponseMessage TextDocumentDefinition diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TypeDefinition.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TypeDefinition.hs new file mode 100644 index 000000000..edd618d67 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TypeDefinition.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.LSP.Types.TypeDefinition where + +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.StaticRegistrationOptions +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +data TypeDefinitionClientCapabilities = TypeDefinitionClientCapabilities + { -- | Whether implementation supports dynamic registration. If this is set + -- to 'True' + -- the client supports the new 'TypeDefinitionRegistrationOptions' return + -- value for the corresponding server capability as well. + _dynamicRegistration :: Maybe Bool, + -- | The client supports additional metadata in the form of definition links. + -- + -- Since LSP 3.14.0 + _linkSupport :: Maybe Bool + } + deriving (Read, Show, Eq) + +deriveJSON lspOptions ''TypeDefinitionClientCapabilities + +makeExtendingDatatype "TypeDefinitionOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''TypeDefinitionOptions + +makeExtendingDatatype "TypeDefinitionRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''TypeDefinitionOptions + , ''StaticRegistrationOptions + ] [] +deriveJSON lspOptions ''TypeDefinitionRegistrationOptions + +makeExtendingDatatype "TypeDefinitionParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + , ''PartialResultParams + ] [] +deriveJSON lspOptions ''TypeDefinitionParams From 4abdedec41809bd651cf2db2598f8e6ed55fe657 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 12 Aug 2020 17:45:24 +0100 Subject: [PATCH 08/63] Update implementation request --- haskell-lsp-types/haskell-lsp-types.cabal | 1 + .../src/Language/Haskell/LSP/Types.hs | 4 +- .../Haskell/LSP/Types/Capabilities.hs | 2 +- .../Haskell/LSP/Types/ClientCapabilities.hs | 13 +----- .../Haskell/LSP/Types/Implementation.hs | 42 +++++++++++++++++++ .../src/Language/Haskell/LSP/Types/Lens.hs | 1 + .../src/Language/Haskell/LSP/Types/Message.hs | 5 ++- .../Haskell/LSP/Types/Registration.hs | 3 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 40 +----------------- 9 files changed, 55 insertions(+), 56 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Implementation.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index 668a23472..fb1ec6a3b 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -37,6 +37,7 @@ library , Language.Haskell.LSP.Types.FoldingRange , Language.Haskell.LSP.Types.Formatting , Language.Haskell.LSP.Types.Hover + , Language.Haskell.LSP.Types.Implementation , Language.Haskell.LSP.Types.Location , Language.Haskell.LSP.Types.LspId , Language.Haskell.LSP.Types.Empty diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index c8db7bfd5..8457fcf67 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -14,6 +14,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.FoldingRange , module Language.Haskell.LSP.Types.Formatting , module Language.Haskell.LSP.Types.Hover + , module Language.Haskell.LSP.Types.Implementation , module Language.Haskell.LSP.Types.Location , module Language.Haskell.LSP.Types.LspId , module Language.Haskell.LSP.Types.MarkupContent @@ -40,6 +41,7 @@ import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition @@ -49,7 +51,7 @@ import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover -import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.MarkupContent diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 195a20e3e..27cac8811 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -100,7 +100,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (since 3 14 (DeclarationClientCapabilities dynamicReg (Just True))) (Just (DefinitionClientCapabilities dynamicReg (since 3 14 True))) (since 3 6 (TypeDefinitionClientCapabilities dynamicReg (since 3 14 True))) - (since 3 6 (ImplementationClientCapabilities dynamicReg)) + (since 3 6 (ImplementationClientCapabilities dynamicReg (since 3 14 True))) (Just codeActionCapability) (Just (CodeLensClientCapabilities dynamicReg)) (Just (DocumentLinkClientCapabilities dynamicReg)) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index d5662bf59..7033f635b 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -13,6 +13,7 @@ import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Hover +import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.References @@ -708,18 +709,6 @@ data OnTypeFormattingClientCapabilities = $(deriveJSON lspOptions ''OnTypeFormattingClientCapabilities) --- ------------------------------------- --- -data ImplementationClientCapabilities = - ImplementationClientCapabilities - { -- | Whether implementation supports dynamic registration. If this is set to `true` - -- the client supports the new `(TextDocumentRegistrationOptions & StaticRegistrationOptions)` - -- return value for the corresponding server capability as well. - _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''ImplementationClientCapabilities) - -- ------------------------------------- data CodeActionKindClientCapabilities = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Implementation.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Implementation.hs new file mode 100644 index 000000000..4974f88a6 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Implementation.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.LSP.Types.Implementation where + +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.StaticRegistrationOptions +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +data ImplementationClientCapabilities = ImplementationClientCapabilities + { -- | Whether implementation supports dynamic registration. If this is set + -- to 'True' + -- the client supports the new 'ImplementationRegistrationOptions' return + -- value for the corresponding server capability as well. + _dynamicRegistration :: Maybe Bool, + -- | The client supports additional metadata in the form of definition links. + -- + -- Since LSP 3.14.0 + _linkSupport :: Maybe Bool + } + deriving (Read, Show, Eq) + +deriveJSON lspOptions ''ImplementationClientCapabilities + +makeExtendingDatatype "ImplementationOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''ImplementationOptions + +makeExtendingDatatype "ImplementationRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''ImplementationOptions + , ''StaticRegistrationOptions + ] [] +deriveJSON lspOptions ''ImplementationRegistrationOptions + +makeExtendingDatatype "ImplementationParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + , ''PartialResultParams + ] [] +deriveJSON lspOptions ''ImplementationParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 69d987e57..f335d4eef 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -22,6 +22,7 @@ import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover +import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Registration diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 80aeb68aa..dfed0661c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -31,6 +31,7 @@ import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover +import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.Method @@ -93,7 +94,7 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams TextDocumentDeclaration = DeclarationParams MessageParams TextDocumentDefinition = DefinitionParams MessageParams TextDocumentTypeDefinition = TypeDefinitionParams - MessageParams TextDocumentImplementation = TextDocumentPositionParams + MessageParams TextDocumentImplementation = ImplementationParams MessageParams TextDocumentReferences = ReferenceParams MessageParams TextDocumentDocumentHighlight = TextDocumentPositionParams MessageParams TextDocumentDocumentSymbol = DocumentSymbolParams @@ -157,7 +158,7 @@ type family ResponseParams (m :: Method p Request) :: Type where ResponseParams TextDocumentDeclaration = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentDefinition = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentTypeDefinition = Maybe (Location |? List Location |? List LocationLink) - ResponseParams TextDocumentImplementation = LocationResponseParams + ResponseParams TextDocumentImplementation = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentReferences = List Location ResponseParams TextDocumentDocumentHighlight = List DocumentHighlight ResponseParams TextDocumentDocumentSymbol = DSResult diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index a8eef0873..f0c7cdc5b 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -32,6 +32,7 @@ import GHC.Generics import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Declaration @@ -41,7 +42,7 @@ import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover -import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index fe703e467..decfd7108 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -20,11 +20,10 @@ import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover -import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition @@ -294,43 +293,6 @@ instance ToJSON TDS where toJSON (TDSOptions x) = toJSON x toJSON (TDSKind x) = toJSON x --- --------------------------------------------------------------------- - -{- -Goto Implementation Request (:leftwards_arrow_with_hook:) -Since version 3.6.0 - -The goto implementation request is sent from the client to the server to resolve the implementation location of a symbol at a given text document position. - -Request: - -method: ‘textDocument/implementation’ -params: TextDocumentPositionParams -Response: - -result: Location | Location[] | null -error: code and message set in case an exception happens during the definition request. -Registration Options: TextDocumentRegistrationOptions --} - -data ImplementationOptions = - ImplementationOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''ImplementationOptions ["_workDoneProgressOptions"] - -data ImplementationRegistrationOptions = - ImplementationRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _implementationOptions :: ImplementationOptions - , _staticRegistrationOptions :: StaticRegistrationOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''ImplementationRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_implementationOptions" - , "_staticRegistrationOptions" - ] - -- --------------------------------------------------------------------- {- New in 3.0 From 076842f1cf2bc4ab0de9370a069af82776b25665 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 12 Aug 2020 17:48:19 +0100 Subject: [PATCH 09/63] Brush up references request --- .../Language/Haskell/LSP/Types/References.hs | 21 +++++++++---------- .../Haskell/LSP/Types/ServerCapabilities.hs | 2 +- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs index 9734ab057..43499573f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/References.hs @@ -12,18 +12,10 @@ import Language.Haskell.LSP.Types.Utils data ReferencesClientCapabilities = ReferencesClientCapabilities - { _dynamicRegistration :: Maybe Bool + { -- | Whether references supports dynamic registration. + _dynamicRegistration :: Maybe Bool } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''ReferencesClientCapabilities) - -data ReferenceContext = - ReferenceContext - { -- | Include the declaration of the current symbol. - _includeDeclaration :: Bool - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''ReferenceContext +deriveJSON lspOptions ''ReferencesClientCapabilities makeExtendingDatatype "ReferenceOptions" [''WorkDoneProgressOptions] [] deriveJSON lspOptions ''ReferenceOptions @@ -35,6 +27,13 @@ makeExtendingDatatype "ReferenceRegistrationOptions" [] deriveJSON lspOptions ''ReferenceRegistrationOptions +data ReferenceContext = + ReferenceContext + { -- | Include the declaration of the current symbol. + _includeDeclaration :: Bool + } deriving (Read,Show,Eq) +deriveJSON lspOptions ''ReferenceContext + makeExtendingDatatype "ReferenceParams" [ ''TextDocumentPositionParams , ''WorkDoneProgressParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index decfd7108..94c7cb409 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -381,7 +381,7 @@ data ServerCapabilities = -- @since 0.7.0.0 , _implementationProvider :: Maybe (Bool |? ImplementationOptions |? ImplementationRegistrationOptions) -- | The server provides find references support. - , _referencesProvider :: Maybe (Bool |? ReferenceOptions) + , _referencesProvider :: Maybe (Bool |? ReferenceOptions) -- For some reason the spec doesn't include ReferenceRegistrationOptions here -- | The server provides document highlight support. , _documentHighlightProvider :: Maybe (Bool |? DocumentHighlightOptions) -- | The server provides document symbol support. From 1fa605cd7d9690ea397787d43c740b421ea95f63 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 12:37:44 +0100 Subject: [PATCH 10/63] Update documentHighlight --- .../src/Language/Haskell/LSP/Types.hs | 2 + .../Haskell/LSP/Types/ClientCapabilities.hs | 11 +- .../Haskell/LSP/Types/DocumentHighlight.hs | 124 ++++++------------ .../src/Language/Haskell/LSP/Types/Lens.hs | 11 +- .../src/Language/Haskell/LSP/Types/Message.hs | 6 +- .../Haskell/LSP/Types/Registration.hs | 4 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 2 +- 7 files changed, 60 insertions(+), 100 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 8457fcf67..3a1d359f8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -10,6 +10,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Definition , module Language.Haskell.LSP.Types.Diagnostic , module Language.Haskell.LSP.Types.DocumentFilter + , module Language.Haskell.LSP.Types.DocumentHighlight , module Language.Haskell.LSP.Types.Empty , module Language.Haskell.LSP.Types.FoldingRange , module Language.Haskell.LSP.Types.Formatting @@ -47,6 +48,7 @@ import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter +import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 7033f635b..a22f3c857 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -11,6 +11,7 @@ import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition +import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation @@ -643,16 +644,6 @@ instance Default SynchronizationTextDocumentClientCapabilities where def = SynchronizationTextDocumentClientCapabilities def def def def - --- ------------------------------------- - -data DocumentHighlightClientCapabilities = - DocumentHighlightClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''DocumentHighlightClientCapabilities) - -- ------------------------------------- data DocumentSymbolKindClientCapabilities = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs index 854c7bb57..9ebc11e07 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentHighlight.hs @@ -1,86 +1,48 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} module Language.Haskell.LSP.Types.DocumentHighlight where import Data.Aeson import Data.Aeson.TH import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils --- --------------------------------------------------------------------- -{- -Document Highlights Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-highlights-request - -The document highlight request is sent from the client to the server to resolve -a document highlights for a given text document position. For programming -languages this usually highlights all references to the symbol scoped to this -file. However we kept 'textDocument/documentHighlight' and -'textDocument/references' separate requests since the first one is allowed to be -more fuzzy. Symbol matches usually have a DocumentHighlightKind of Read or Write -whereas fuzzy or textual matches use Textas the kind. - - Changed: In 2.0 the request uses TextDocumentPositionParams with proper - textDocument and position properties. In 1.0 the uri of the referenced text - document was inlined into the params object. - -Request - - method: 'textDocument/documentHighlight' - params: TextDocumentPositionParams - -Response - - result: DocumentHighlight[] defined as follows: - -/** - * A document highlight is a range inside a text document which deserves - * special attention. Usually a document highlight is visualized by changing - * the background color of its range. - * - */ -interface DocumentHighlight { - /** - * The range this highlight applies to. - */ - range: Range; - - /** - * The highlight kind, default is DocumentHighlightKind.Text. - */ - kind?: number; -} - -/** - * A document highlight kind. - */ -enum DocumentHighlightKind { - /** - * A textual occurrance. - */ - Text = 1, - - /** - * Read-access of a symbol, like reading a variable. - */ - Read = 2, - - /** - * Write-access of a symbol, like writing to a variable. - */ - Write = 3 -} - - error: code and message set in case an exception happens during the document - highlight request. - -Registration Options: TextDocumentRegistrationOptions - --} +-- ------------------------------------- -data DocumentHighlightKind = HkText | HkRead | HkWrite - deriving (Read,Show,Eq) +data DocumentHighlightClientCapabilities = + DocumentHighlightClientCapabilities + { -- | Whether document highlight supports dynamic registration. + _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DocumentHighlightClientCapabilities + +makeExtendingDatatype "DocumentHighlightOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''DocumentHighlightOptions + +makeExtendingDatatype "DocumentHighlightRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''DocumentHighlightOptions + ] [] +deriveJSON lspOptions ''DocumentHighlightRegistrationOptions + +makeExtendingDatatype "DocumentHighlightParams" + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams + , ''PartialResultParams + ] [] +deriveJSON lspOptions ''DocumentHighlightParams + +data DocumentHighlightKind + = -- | A textual occurrence. + HkText + | -- | Read-access of a symbol, like reading a variable. + HkRead + | -- | Write-access of a symbol, like writing to a variable. + HkWrite + deriving (Read, Show, Eq) instance ToJSON DocumentHighlightKind where toJSON HkText = Number 1 @@ -95,17 +57,15 @@ instance FromJSON DocumentHighlightKind where -- ------------------------------------- +-- | A document highlight is a range inside a text document which deserves +-- special attention. Usually a document highlight is visualized by changing the +-- background color of its range. data DocumentHighlight = DocumentHighlight - { _range :: Range + { -- | The range this highlight applies to. + _range :: Range + -- | The highlight kind, default is 'HkText'. , _kind :: Maybe DocumentHighlightKind } deriving (Read,Show,Eq) deriveJSON lspOptions ''DocumentHighlight - -data DocumentHighlightOptions = - DocumentHighlightOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) - -deriveJSONExtendFields lspOptions ''DocumentHighlightOptions ["_workDoneProgressOptions"] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index f335d4eef..21162e65a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -59,7 +59,6 @@ makeFieldsNoPrefix ''SignatureHelpSignatureInformation makeFieldsNoPrefix ''SignatureHelpParameterInformation makeFieldsNoPrefix ''SignatureHelpClientCapabilities makeFieldsNoPrefix ''ReferencesClientCapabilities -makeFieldsNoPrefix ''DocumentHighlightClientCapabilities makeFieldsNoPrefix ''DocumentSymbolKindClientCapabilities makeFieldsNoPrefix ''DocumentSymbolClientCapabilities makeFieldsNoPrefix ''FormattingClientCapabilities @@ -125,7 +124,6 @@ makeFieldsNoPrefix ''SignatureHelp makeFieldsNoPrefix ''SignatureHelpRegistrationOptions makeFieldsNoPrefix ''ReferenceContext makeFieldsNoPrefix ''ReferenceParams -makeFieldsNoPrefix ''DocumentHighlight makeFieldsNoPrefix ''WorkspaceSymbolParams makeFieldsNoPrefix ''CodeLensParams makeFieldsNoPrefix ''CodeLens @@ -163,6 +161,15 @@ makeFieldsNoPrefix ''CodeActionContext makeFieldsNoPrefix ''CodeActionParams makeFieldsNoPrefix ''CodeAction +-- DocumentHighlight +concat <$> mapM makeFieldsNoPrefix + [ ''DocumentHighlightClientCapabilities + , ''DocumentHighlightOptions + , ''DocumentHighlightRegistrationOptions + , ''DocumentHighlightParams + , ''DocumentHighlight + ] + -- DocumentFilter makeFieldsNoPrefix ''DocumentFilter diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index dfed0661c..ffca9d943 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -96,7 +96,7 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams TextDocumentTypeDefinition = TypeDefinitionParams MessageParams TextDocumentImplementation = ImplementationParams MessageParams TextDocumentReferences = ReferenceParams - MessageParams TextDocumentDocumentHighlight = TextDocumentPositionParams + MessageParams TextDocumentDocumentHighlight = DocumentHighlightParams MessageParams TextDocumentDocumentSymbol = DocumentSymbolParams -- Code Action/Lens/Link MessageParams TextDocumentCodeAction = CodeActionParams @@ -159,8 +159,8 @@ type family ResponseParams (m :: Method p Request) :: Type where ResponseParams TextDocumentDefinition = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentTypeDefinition = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentImplementation = Maybe (Location |? List Location |? List LocationLink) - ResponseParams TextDocumentReferences = List Location - ResponseParams TextDocumentDocumentHighlight = List DocumentHighlight + ResponseParams TextDocumentReferences = Maybe (List Location) + ResponseParams TextDocumentDocumentHighlight = Maybe (List DocumentHighlight) ResponseParams TextDocumentDocumentSymbol = DSResult -- Code Action/Lens/Link ResponseParams TextDocumentCodeAction = List CAResult diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index f0c7cdc5b..0005ac958 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -37,6 +37,7 @@ import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition +import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange @@ -124,8 +125,7 @@ type family RegistrationOptions (m :: Method FromClient t) :: Type where RegistrationOptions TextDocumentTypeDefinition = TypeDefinitionRegistrationOptions RegistrationOptions TextDocumentImplementation = ImplementationRegistrationOptions RegistrationOptions TextDocumentReferences = ReferenceRegistrationOptions - -- TODO: Add me once textDocument/highlights is implemented - -- RegistrationOptions TextDocumentHighlights = DocumentHighlightRegistrationOptions + RegistrationOptions TextDocumentDocumentHighlight = DocumentHighlightRegistrationOptions RegistrationOptions TextDocumentDocumentSymbol = DocumentSymbolRegistrationOptions RegistrationOptions TextDocumentCodeAction = CodeActionRegistrationOptions RegistrationOptions TextDocumentCodeLens = CodeLensRegistrationOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 94c7cb409..decfd7108 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -381,7 +381,7 @@ data ServerCapabilities = -- @since 0.7.0.0 , _implementationProvider :: Maybe (Bool |? ImplementationOptions |? ImplementationRegistrationOptions) -- | The server provides find references support. - , _referencesProvider :: Maybe (Bool |? ReferenceOptions) -- For some reason the spec doesn't include ReferenceRegistrationOptions here + , _referencesProvider :: Maybe (Bool |? ReferenceOptions) -- | The server provides document highlight support. , _documentHighlightProvider :: Maybe (Bool |? DocumentHighlightOptions) -- | The server provides document symbol support. From f26f464878f326d602ced9d8f8ddb4193d64e477 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 13:14:21 +0100 Subject: [PATCH 11/63] Update documentSymbol --- haskell-lsp-types/haskell-lsp-types.cabal | 2 +- .../src/Language/Haskell/LSP/Types.hs | 4 +- .../Haskell/LSP/Types/Capabilities.hs | 6 +- .../Haskell/LSP/Types/ClientCapabilities.hs | 59 ++----- .../Types/{Symbol.hs => DocumentSymbol.hs} | 163 +++++------------- .../src/Language/Haskell/LSP/Types/Lens.hs | 36 ++-- .../src/Language/Haskell/LSP/Types/Message.hs | 4 +- .../Haskell/LSP/Types/Registration.hs | 2 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 2 +- 9 files changed, 87 insertions(+), 191 deletions(-) rename haskell-lsp-types/src/Language/Haskell/LSP/Types/{Symbol.hs => DocumentSymbol.hs} (67%) diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index fb1ec6a3b..b7169e84a 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -51,7 +51,7 @@ library , Language.Haskell.LSP.Types.ServerCapabilities , Language.Haskell.LSP.Types.SignatureHelp , Language.Haskell.LSP.Types.StaticRegistrationOptions - , Language.Haskell.LSP.Types.Symbol + , Language.Haskell.LSP.Types.DocumentSymbol , Language.Haskell.LSP.Types.Synonyms , Language.Haskell.LSP.Types.TextDocument , Language.Haskell.LSP.Types.TypeDefinition diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 3a1d359f8..edf673398 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -26,7 +26,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Rename , module Language.Haskell.LSP.Types.SignatureHelp , module Language.Haskell.LSP.Types.StaticRegistrationOptions - , module Language.Haskell.LSP.Types.Symbol + , module Language.Haskell.LSP.Types.DocumentSymbol , module Language.Haskell.LSP.Types.Synonyms , module Language.Haskell.LSP.Types.TextDocument , module Language.Haskell.LSP.Types.TypeDefinition @@ -64,7 +64,7 @@ import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.StaticRegistrationOptions -import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.Synonyms import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 27cac8811..6a0be7273 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -41,16 +41,16 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (Just (DidChangeConfigurationClientCapabilities dynamicReg)) (Just (DidChangeWatchedFilesClientCapabilities dynamicReg)) (Just symbolCapabilities) - (Just (ExecuteClientCapabilities dynamicReg)) + (Just (ExecuteCommandClientCapabilities dynamicReg)) (since 3 6 True) (since 3 6 True) - symbolCapabilities = SymbolClientCapabilities + symbolCapabilities = WorkspaceSymbolClientCapabilities dynamicReg (since 3 4 symbolKindCapabilities) symbolKindCapabilities = - SymbolKindClientCapabilities (Just sKs) + WorkspaceSymbolKindClientCapabilities (Just sKs) sKs | maj >= 3 && min >= 4 = List (oldSKs ++ newSKs) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index a22f3c857..723143756 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -12,11 +12,11 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.Symbol import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils @@ -153,8 +153,8 @@ $(deriveJSON lspOptions ''DidChangeWatchedFilesClientCapabilities) -- ------------------------------------- -data SymbolKindClientCapabilities = - SymbolKindClientCapabilities +data WorkspaceSymbolKindClientCapabilities = + WorkspaceSymbolKindClientCapabilities { -- | The symbol kind values the client supports. When this -- property exists the client also guarantees that it will -- handle values outside its set gracefully and falls back @@ -166,10 +166,10 @@ data SymbolKindClientCapabilities = _valueSet :: Maybe (List SymbolKind) } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''SymbolKindClientCapabilities) +$(deriveJSON lspOptions ''WorkspaceSymbolKindClientCapabilities) -instance Default SymbolKindClientCapabilities where - def = SymbolKindClientCapabilities (Just $ List allKinds) +instance Default WorkspaceSymbolKindClientCapabilities where + def = WorkspaceSymbolKindClientCapabilities (Just $ List allKinds) where allKinds = [ SkFile , SkModule , SkNamespace @@ -190,24 +190,24 @@ instance Default SymbolKindClientCapabilities where , SkArray ] -data SymbolClientCapabilities = - SymbolClientCapabilities +data WorkspaceSymbolClientCapabilities = + WorkspaceSymbolClientCapabilities { _dynamicRegistration :: Maybe Bool -- ^Symbol request supports dynamic -- registration. - , _symbolKind :: Maybe SymbolKindClientCapabilities -- ^ Specific capabilities for the `SymbolKind`. + , _symbolKind :: Maybe WorkspaceSymbolKindClientCapabilities -- ^ Specific capabilities for the `SymbolKind`. } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''SymbolClientCapabilities) +deriveJSON lspOptions ''WorkspaceSymbolClientCapabilities -- ------------------------------------- -data ExecuteClientCapabilities = - ExecuteClientCapabilities +data ExecuteCommandClientCapabilities = + ExecuteCommandClientCapabilities { _dynamicRegistration :: Maybe Bool -- ^Execute command supports dynamic -- registration. } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ExecuteClientCapabilities) +$(deriveJSON lspOptions ''ExecuteCommandClientCapabilities) -- ------------------------------------- @@ -227,10 +227,10 @@ data WorkspaceClientCapabilities = , _didChangeWatchedFiles :: Maybe DidChangeWatchedFilesClientCapabilities -- | Capabilities specific to the `workspace/symbol` request. - , _symbol :: Maybe SymbolClientCapabilities + , _symbol :: Maybe WorkspaceSymbolClientCapabilities -- | Capabilities specific to the `workspace/executeCommand` request. - , _executeCommand :: Maybe ExecuteClientCapabilities + , _executeCommand :: Maybe ExecuteCommandClientCapabilities -- | The client has support for workspace folders. , _workspaceFolders :: Maybe Bool @@ -644,35 +644,6 @@ instance Default SynchronizationTextDocumentClientCapabilities where def = SynchronizationTextDocumentClientCapabilities def def def def --- ------------------------------------- - -data DocumentSymbolKindClientCapabilities = - DocumentSymbolKindClientCapabilities - { -- | The symbol kind values the client supports. When this - -- property exists the client also guarantees that it will - -- handle values outside its set gracefully and falls back - -- to a default value when unknown. - -- - -- If this property is not present the client only supports - -- the symbol kinds from `File` to `Array` as defined in - -- the initial version of the protocol. - _valueSet :: Maybe (List SymbolKind) - } - deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''DocumentSymbolKindClientCapabilities) - -data DocumentSymbolClientCapabilities = - DocumentSymbolClientCapabilities - { -- | Whether document symbol supports dynamic registration. - _dynamicRegistration :: Maybe Bool - -- | Specific capabilities for the `SymbolKind`. - , _symbolKind :: Maybe DocumentSymbolKindClientCapabilities - , _hierarchicalDocumentSymbolSupport :: Maybe Bool - } deriving (Show, Read, Eq) - -$(deriveJSON lspOptions ''DocumentSymbolClientCapabilities) - -- ------------------------------------- data FormattingClientCapabilities = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentSymbol.hs similarity index 67% rename from haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs rename to haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentSymbol.hs index 0b4ebb427..7138af5d9 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Symbol.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentSymbol.hs @@ -1,8 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} -module Language.Haskell.LSP.Types.Symbol where +module Language.Haskell.LSP.Types.DocumentSymbol where -import Control.Applicative import Data.Aeson import Data.Aeson.TH import Data.Scientific @@ -15,97 +14,23 @@ import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- -{- -Document Symbols Request -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-symbols-request +makeExtendingDatatype "DocumentSymbolOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''DocumentSymbolOptions -The document symbol request is sent from the client to the server to list all -symbols found in a given text document. +makeExtendingDatatype "DocumentSymbolRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''DocumentSymbolOptions + ] [] +deriveJSON lspOptions ''DocumentSymbolRegistrationOptions - Changed: In 2.0 the request uses DocumentSymbolParams instead of a single - uri. - -Request - - method: 'textDocument/documentSymbol' - params: DocumentSymbolParams defined as follows: - -interface DocumentSymbolParams { - /** - * The text document. - */ - textDocument: TextDocumentIdentifier; -} - -Response - - result: SymbolInformation[] defined as follows: - -/** - * Represents information about programming constructs like variables, classes, - * interfaces etc. - */ -interface SymbolInformation { - /** - * The name of this symbol. - */ - name: string; - - /** - * The kind of this symbol. - */ - kind: number; - - /** - * The location of this symbol. - */ - location: Location; - - /** - * The name of the symbol containing this symbol. - */ - containerName?: string; -} - -Where the kind is defined like this: - -/** - * A symbol kind. - */ -export enum SymbolKind { - File = 1, - Module = 2, - Namespace = 3, - Package = 4, - Class = 5, - Method = 6, - Property = 7, - Field = 8, - Constructor = 9, - Enum = 10, - Interface = 11, - Function = 12, - Variable = 13, - Constant = 14, - Text = 15, - Number = 16, - Boolean = 17, - Array = 18, -} - - error: code and message set in case an exception happens during the document - symbol request. - -Registration Options: TextDocumentRegistrationOptions --} - -data DocumentSymbolParams = - DocumentSymbolParams - { _textDocument :: TextDocumentIdentifier - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) +-- --------------------------------------------------------------------- +makeExtendingDatatype "DocumentSymbolParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [ ("_textDocument", [t| TextDocumentIdentifier |])] deriveJSON lspOptions ''DocumentSymbolParams -- ------------------------------------- @@ -198,6 +123,36 @@ instance FromJSON SymbolKind where parseJSON (Number 26) = pure SkTypeParameter parseJSON (Number x) = pure (SkUnknown x) parseJSON _ = mempty + +-- ------------------------------------- + +data DocumentSymbolKindClientCapabilities = + DocumentSymbolKindClientCapabilities + { -- | The symbol kind values the client supports. When this + -- property exists the client also guarantees that it will + -- handle values outside its set gracefully and falls back + -- to a default value when unknown. + -- + -- If this property is not present the client only supports + -- the symbol kinds from `File` to `Array` as defined in + -- the initial version of the protocol. + _valueSet :: Maybe (List SymbolKind) + } + deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DocumentSymbolKindClientCapabilities + +data DocumentSymbolClientCapabilities = + DocumentSymbolClientCapabilities + { -- | Whether document symbol supports dynamic registration. + _dynamicRegistration :: Maybe Bool + -- | Specific capabilities for the `SymbolKind`. + , _symbolKind :: Maybe DocumentSymbolKindClientCapabilities + , _hierarchicalDocumentSymbolSupport :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DocumentSymbolClientCapabilities + -- --------------------------------------------------------------------- @@ -254,33 +209,3 @@ data SymbolInformation = } deriving (Read,Show,Eq) deriveJSON lspOptions ''SymbolInformation - --- ------------------------------------- - -data DSResult = DSDocumentSymbols (List DocumentSymbol) - | DSSymbolInformation (List SymbolInformation) - deriving (Read,Show,Eq) - -instance FromJSON DSResult where - parseJSON x = DSDocumentSymbols <$> parseJSON x <|> DSSymbolInformation <$> parseJSON x - -instance ToJSON DSResult where - toJSON (DSDocumentSymbols x) = toJSON x - toJSON (DSSymbolInformation x) = toJSON x - -data DocumentSymbolOptions = - DocumentSymbolOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } - deriving (Read, Show, Eq) - -deriveJSONExtendFields lspOptions ''DocumentSymbolOptions ["_workDoneProgressOptions"] - -data DocumentSymbolRegistrationOptions = - DocumentSymbolRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _documentSymbolOptions :: DocumentSymbolOptions - } - deriving (Read, Show, Eq) - -deriveJSONExtendFields lspOptions ''DocumentSymbolRegistrationOptions ["_textDocumentRegistrationOptions", "_documentSymbolOptions"] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 21162e65a..4d88a7902 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -30,7 +30,7 @@ import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.ServerCapabilities -import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Window @@ -45,9 +45,9 @@ import Control.Lens.TH makeFieldsNoPrefix ''WorkspaceEditClientCapabilities makeFieldsNoPrefix ''DidChangeConfigurationClientCapabilities makeFieldsNoPrefix ''DidChangeWatchedFilesClientCapabilities -makeFieldsNoPrefix ''SymbolKindClientCapabilities -makeFieldsNoPrefix ''SymbolClientCapabilities -makeFieldsNoPrefix ''ExecuteClientCapabilities +makeFieldsNoPrefix ''WorkspaceSymbolKindClientCapabilities +makeFieldsNoPrefix ''WorkspaceSymbolClientCapabilities +makeFieldsNoPrefix ''ExecuteCommandClientCapabilities makeFieldsNoPrefix ''WorkspaceClientCapabilities makeFieldsNoPrefix ''SynchronizationTextDocumentClientCapabilities makeFieldsNoPrefix ''CompletionItemTagsClientCapabilities @@ -59,8 +59,6 @@ makeFieldsNoPrefix ''SignatureHelpSignatureInformation makeFieldsNoPrefix ''SignatureHelpParameterInformation makeFieldsNoPrefix ''SignatureHelpClientCapabilities makeFieldsNoPrefix ''ReferencesClientCapabilities -makeFieldsNoPrefix ''DocumentSymbolKindClientCapabilities -makeFieldsNoPrefix ''DocumentSymbolClientCapabilities makeFieldsNoPrefix ''FormattingClientCapabilities makeFieldsNoPrefix ''RangeFormattingClientCapabilities makeFieldsNoPrefix ''OnTypeFormattingClientCapabilities @@ -162,13 +160,20 @@ makeFieldsNoPrefix ''CodeActionParams makeFieldsNoPrefix ''CodeAction -- DocumentHighlight -concat <$> mapM makeFieldsNoPrefix - [ ''DocumentHighlightClientCapabilities - , ''DocumentHighlightOptions - , ''DocumentHighlightRegistrationOptions - , ''DocumentHighlightParams - , ''DocumentHighlight - ] +makeFieldsNoPrefix ''DocumentHighlightClientCapabilities +makeFieldsNoPrefix ''DocumentHighlightOptions +makeFieldsNoPrefix ''DocumentHighlightRegistrationOptions +makeFieldsNoPrefix ''DocumentHighlightParams +makeFieldsNoPrefix ''DocumentHighlight + +-- DocumentSymbol +makeFieldsNoPrefix ''DocumentSymbolKindClientCapabilities +makeFieldsNoPrefix ''DocumentSymbolClientCapabilities +makeFieldsNoPrefix ''DocumentSymbolOptions +makeFieldsNoPrefix ''DocumentSymbolRegistrationOptions +makeFieldsNoPrefix ''DocumentSymbolParams +makeFieldsNoPrefix ''DocumentSymbol +makeFieldsNoPrefix ''SymbolInformation -- DocumentFilter makeFieldsNoPrefix ''DocumentFilter @@ -207,11 +212,6 @@ makeFieldsNoPrefix ''DiagnosticRelatedInformation makeFieldsNoPrefix ''Hover makeFieldsNoPrefix ''HoverRegistrationOptions --- Symbol -makeFieldsNoPrefix ''DocumentSymbolParams -makeFieldsNoPrefix ''DocumentSymbol -makeFieldsNoPrefix ''SymbolInformation - -- Color makeFieldsNoPrefix ''Color makeFieldsNoPrefix ''ColorInformation diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index ffca9d943..9a2998c37 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -40,7 +40,7 @@ import Language.Haskell.LSP.Types.Registration import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils @@ -161,7 +161,7 @@ type family ResponseParams (m :: Method p Request) :: Type where ResponseParams TextDocumentImplementation = Maybe (Location |? List Location |? List LocationLink) ResponseParams TextDocumentReferences = Maybe (List Location) ResponseParams TextDocumentDocumentHighlight = Maybe (List DocumentHighlight) - ResponseParams TextDocumentDocumentSymbol = DSResult + ResponseParams TextDocumentDocumentSymbol = Maybe (List DocumentSymbol |? List SymbolInformation) -- Code Action/Lens/Link ResponseParams TextDocumentCodeAction = List CAResult ResponseParams TextDocumentCodeLens = List CodeLens diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index 0005ac958..233db3f8f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -48,7 +48,7 @@ import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index decfd7108..341c68565 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -24,7 +24,7 @@ import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.Symbol +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils From 065a307733c753ef70cea273b8d49685c15822bd Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 13:17:05 +0100 Subject: [PATCH 12/63] Remove redundant TH $() in splices --- .../Haskell/LSP/Types/ClientCapabilities.hs | 46 +++++++++---------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 723143756..55cd054bf 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -127,7 +127,7 @@ data WorkspaceEditClientCapabilities = -- changes in `WorkspaceEdit`s } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''WorkspaceEditClientCapabilities) +deriveJSON lspOptions ''WorkspaceEditClientCapabilities -- ------------------------------------- @@ -138,7 +138,7 @@ data DidChangeConfigurationClientCapabilities = -- registration. } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DidChangeConfigurationClientCapabilities) +deriveJSON lspOptions ''DidChangeConfigurationClientCapabilities -- ------------------------------------- @@ -149,7 +149,7 @@ data DidChangeWatchedFilesClientCapabilities = -- registration. } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DidChangeWatchedFilesClientCapabilities) +deriveJSON lspOptions ''DidChangeWatchedFilesClientCapabilities -- ------------------------------------- @@ -166,7 +166,7 @@ data WorkspaceSymbolKindClientCapabilities = _valueSet :: Maybe (List SymbolKind) } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''WorkspaceSymbolKindClientCapabilities) +deriveJSON lspOptions ''WorkspaceSymbolKindClientCapabilities instance Default WorkspaceSymbolKindClientCapabilities where def = WorkspaceSymbolKindClientCapabilities (Just $ List allKinds) @@ -207,7 +207,7 @@ data ExecuteCommandClientCapabilities = -- registration. } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ExecuteCommandClientCapabilities) +deriveJSON lspOptions ''ExecuteCommandClientCapabilities -- ------------------------------------- @@ -239,7 +239,7 @@ data WorkspaceClientCapabilities = , _configuration :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''WorkspaceClientCapabilities) +deriveJSON lspOptions ''WorkspaceClientCapabilities instance Default WorkspaceClientCapabilities where def = WorkspaceClientCapabilities def def def def def def def def @@ -638,7 +638,7 @@ data SynchronizationTextDocumentClientCapabilities = , _didSave :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''SynchronizationTextDocumentClientCapabilities) +deriveJSON lspOptions ''SynchronizationTextDocumentClientCapabilities instance Default SynchronizationTextDocumentClientCapabilities where def = SynchronizationTextDocumentClientCapabilities def def def def @@ -651,7 +651,7 @@ data FormattingClientCapabilities = { _dynamicRegistration :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''FormattingClientCapabilities) +deriveJSON lspOptions ''FormattingClientCapabilities -- ------------------------------------- @@ -660,7 +660,7 @@ data RangeFormattingClientCapabilities = { _dynamicRegistration :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''RangeFormattingClientCapabilities) +deriveJSON lspOptions ''RangeFormattingClientCapabilities -- ------------------------------------- @@ -669,7 +669,7 @@ data OnTypeFormattingClientCapabilities = { _dynamicRegistration :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''OnTypeFormattingClientCapabilities) +deriveJSON lspOptions ''OnTypeFormattingClientCapabilities -- ------------------------------------- @@ -682,7 +682,7 @@ data CodeActionKindClientCapabilities = _valueSet :: List CodeActionKind } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''CodeActionKindClientCapabilities) +deriveJSON lspOptions ''CodeActionKindClientCapabilities instance Default CodeActionKindClientCapabilities where def = CodeActionKindClientCapabilities (List allKinds) @@ -700,7 +700,7 @@ data CodeActionLiteralSupport = { _codeActionKind :: CodeActionKindClientCapabilities -- ^ The code action kind is support with the following value set. } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''CodeActionLiteralSupport) +deriveJSON lspOptions ''CodeActionLiteralSupport data CodeActionClientCapabilities = CodeActionClientCapabilities @@ -710,7 +710,7 @@ data CodeActionClientCapabilities = -- Since 3.8.0 } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''CodeActionClientCapabilities) +deriveJSON lspOptions ''CodeActionClientCapabilities -- ------------------------------------- @@ -719,7 +719,7 @@ data CodeLensClientCapabilities = { _dynamicRegistration :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''CodeLensClientCapabilities) +deriveJSON lspOptions ''CodeLensClientCapabilities -- ------------------------------------- @@ -728,7 +728,7 @@ data DocumentLinkClientCapabilities = { _dynamicRegistration :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DocumentLinkClientCapabilities) +deriveJSON lspOptions ''DocumentLinkClientCapabilities -- ------------------------------------- @@ -740,7 +740,7 @@ data ColorProviderClientCapabilities = _dynamicRegistration :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ColorProviderClientCapabilities) +deriveJSON lspOptions ''ColorProviderClientCapabilities -- ------------------------------------- @@ -750,7 +750,7 @@ data RenameClientCapabilities = , _prepareSupport :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''RenameClientCapabilities) +deriveJSON lspOptions ''RenameClientCapabilities -- ------------------------------------- @@ -760,7 +760,7 @@ data PublishDiagnosticsTagsClientCapabilities = _valueSet :: List DiagnosticTag } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''PublishDiagnosticsTagsClientCapabilities) +deriveJSON lspOptions ''PublishDiagnosticsTagsClientCapabilities data PublishDiagnosticsClientCapabilities = PublishDiagnosticsClientCapabilities @@ -773,7 +773,7 @@ data PublishDiagnosticsClientCapabilities = , _tagSupport :: Maybe PublishDiagnosticsTagsClientCapabilities } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''PublishDiagnosticsClientCapabilities) +deriveJSON lspOptions ''PublishDiagnosticsClientCapabilities -- ------------------------------------- @@ -793,7 +793,7 @@ data FoldingRangeClientCapabilities = , _lineFoldingOnly :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''FoldingRangeClientCapabilities) +deriveJSON lspOptions ''FoldingRangeClientCapabilities -- ------------------------------------- @@ -867,7 +867,7 @@ data TextDocumentClientCapabilities = , _foldingRange :: Maybe FoldingRangeClientCapabilities } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentClientCapabilities) +deriveJSON lspOptions ''TextDocumentClientCapabilities instance Default TextDocumentClientCapabilities where def = TextDocumentClientCapabilities def def def def def def def def @@ -883,7 +883,7 @@ data WindowClientCapabilities = _workDoneProgress :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''WindowClientCapabilities) +deriveJSON lspOptions ''WindowClientCapabilities instance Default WindowClientCapabilities where def = WindowClientCapabilities def @@ -947,7 +947,7 @@ data ClientCapabilities = , _experimental :: Maybe A.Object } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ClientCapabilities) +deriveJSON lspOptions ''ClientCapabilities instance Default ClientCapabilities where def = ClientCapabilities def def def def From 01a04fc49cfd7f074738ec2dd19742df1a5f1036 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 13:58:02 +0100 Subject: [PATCH 13/63] Update codeAction --- .../Haskell/LSP/Types/Capabilities.hs | 1 + .../Haskell/LSP/Types/ClientCapabilities.hs | 40 -- .../Language/Haskell/LSP/Types/CodeAction.hs | 435 +++++++----------- .../src/Language/Haskell/LSP/Types/Lens.hs | 8 +- .../src/Language/Haskell/LSP/Types/Message.hs | 28 +- 5 files changed, 181 insertions(+), 331 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 6a0be7273..3494581f7 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -178,6 +178,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth = CodeActionClientCapabilities dynamicReg (since 3 8 (CodeActionLiteralSupport caKs)) + (since 3 15 True) caKs = CodeActionKindClientCapabilities (List [ CodeActionQuickFix , CodeActionRefactor diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 55cd054bf..c417ec63a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -671,46 +671,6 @@ data OnTypeFormattingClientCapabilities = deriveJSON lspOptions ''OnTypeFormattingClientCapabilities --- ------------------------------------- - -data CodeActionKindClientCapabilities = - CodeActionKindClientCapabilities - { -- | The code action kind values the client supports. When this - -- property exists the client also guarantees that it will - -- handle values outside its set gracefully and falls back - -- to a default value when unknown. - _valueSet :: List CodeActionKind - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''CodeActionKindClientCapabilities - -instance Default CodeActionKindClientCapabilities where - def = CodeActionKindClientCapabilities (List allKinds) - where allKinds = [ CodeActionQuickFix - , CodeActionRefactor - , CodeActionRefactorExtract - , CodeActionRefactorInline - , CodeActionRefactorRewrite - , CodeActionSource - , CodeActionSourceOrganizeImports - ] - -data CodeActionLiteralSupport = - CodeActionLiteralSupport - { _codeActionKind :: CodeActionKindClientCapabilities -- ^ The code action kind is support with the following value set. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''CodeActionLiteralSupport - -data CodeActionClientCapabilities = - CodeActionClientCapabilities - { _dynamicRegistration :: Maybe Bool -- ^ Whether code action supports dynamic registration. - , _codeActionLiteralSupport :: Maybe CodeActionLiteralSupport -- ^ The client support code action literals as a valid response - -- of the `textDocument/codeAction` request. - -- Since 3.8.0 - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''CodeActionClientCapabilities -- ------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs index 855399edf..27c3739f1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeAction.hs @@ -3,9 +3,9 @@ {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.LSP.Types.CodeAction where -import Control.Applicative import Data.Aeson.TH import Data.Aeson.Types +import Data.Default import Data.Text ( Text ) import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Diagnostic @@ -17,210 +17,53 @@ import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.WorkspaceEdit -{- -Code Action Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#code-action-request - -The code action request is sent from the client to the server to compute commands -for a given text document and range. These commands are typically code fixes to -either fix problems or to beautify/refactor code. The result of a -textDocument/codeAction request is an array of Command literals which are -typically presented in the user interface. When the command is selected the -server should be contacted again (via the workspace/executeCommand) request to -execute the command. - -Since version 3.8.0: support for CodeAction litarals to enable the following -scenarios: - -the ability to directly return a workspace edit from e code action request. This -avoids having another server roundtrip to execute an actual code action. However -server providers should be aware that if the code action is expensive to compute -or the edits are huge it might still be beneficial if the result is imply a -command and the actual edit is only computed when needed. the ability to group -code actions using a kind. Clients are allowed to ignore that information. -However it allows them to better group code action for example into -corresponding menus (e.g. all refactor code actions into a refactor menu). -Clients need to announce there support code action literals and code action -kinds via the corresponding client capability -textDocument.codeAction.codeActionLiteralSupport. - -Request - - method: 'textDocument/codeAction' - params: CodeActionParams defined as follows: - -/** - * Params for the CodeActionRequest - */ -interface CodeActionParams { - /** - * The document in which the command was invoked. - */ - textDocument: TextDocumentIdentifier; - - /** - * The range for which the command was invoked. - */ - range: Range; - - /** - * Context carrying additional information. - */ - context: CodeActionContext; -} - -/** - * The kind of a code action. - * - * Kinds are a hierarchical list of identifiers separated by `.`, e.g. `"refactor.extract.function"`. - * - * The set of kinds is open and client needs to announce the kinds it supports to the server during - * initialization. - */ -export type CodeActionKind = string; - -/** - * A set of predefined code action kinds - */ -export namespace CodeActionKind { - /** - * Base kind for quickfix actions: 'quickfix' - */ - export const QuickFix: CodeActionKind = 'quickfix'; - - /** - * Base kind for refactoring actions: 'refactor' - */ - export const Refactor: CodeActionKind = 'refactor'; - - /** - * Base kind for refactoring extraction actions: 'refactor.extract' - * - * Example extract actions: - * - * - Extract method - * - Extract function - * - Extract variable - * - Extract interface from class - * - ... - */ - export const RefactorExtract: CodeActionKind = 'refactor.extract'; - - /** - * Base kind for refactoring inline actions: 'refactor.inline' - * - * Example inline actions: - * - * - Inline function - * - Inline variable - * - Inline constant - * - ... - */ - export const RefactorInline: CodeActionKind = 'refactor.inline'; - - /** - * Base kind for refactoring rewrite actions: 'refactor.rewrite' - * - * Example rewrite actions: - * - * - Convert JavaScript function to class - * - Add or remove parameter - * - Encapsulate field - * - Make method static - * - Move method to base class - * - ... - */ - export const RefactorRewrite: CodeActionKind = 'refactor.rewrite'; - - /** - * Base kind for source actions: `source` - * - * Source code actions apply to the entire file. - */ - export const Source: CodeActionKind = 'source'; - - /** - * Base kind for an organize imports source action: `source.organizeImports` - */ - export const SourceOrganizeImports: CodeActionKind = 'source.organizeImports'; -} - -/** - * Contains additional diagnostic information about the context in which - * a code action is run. - */ -interface CodeActionContext { - /** - * An array of diagnostics. - */ - diagnostics: Diagnostic[]; - - /** - * Requested kind of actions to return. - * - * Actions not of this kind are filtered out by the client before being shown. So servers - * can omit computing them. - */ - only?: CodeActionKind[]; -} - -Response - - result: (Command | CodeAction)[] | null where CodeAction is defined as follows: - /** - * A code action represents a change that can be performed in code, e.g. to fix a problem or - * to refactor code. - * - * A CodeAction must set either `edit` and/or a `command`. If both are supplied, the `edit` is applied first, then the `command` is executed. - */ - export interface CodeAction { - - /** - * A short, human-readable, title for this code action. - */ - title: string; - - /** - * The kind of the code action. - * - * Used to filter code actions. - */ - kind?: CodeActionKind; - - /** - * The diagnostics that this code action resolves. - */ - diagnostics?: Diagnostic[]; - - /** - * The workspace edit this code action performs. - */ - edit?: WorkspaceEdit; - - /** - * A command this code action executes. If a code action - * provides an edit and a command, first the edit is - * executed and then the command. - */ - command?: Command; - } - error: code and message set in case an exception happens during the code - action request. - --} - -data CodeActionKind = CodeActionQuickFix - | CodeActionRefactor - | CodeActionRefactorExtract - | CodeActionRefactorInline - | CodeActionRefactorRewrite - | CodeActionSource - | CodeActionSourceOrganizeImports - | CodeActionUnknown Text - deriving (Read,Show,Eq) +data CodeActionKind + = -- | Empty kind. + CodeActionEmpty + | -- | Base kind for quickfix actions: @quickfix@. + CodeActionQuickFix + | -- | Base kind for refactoring actions: @refactor@. + CodeActionRefactor + | -- | Base kind for refactoring extraction actions: @refactor.extract@. + -- Example extract actions: + -- + -- - Extract method + -- - Extract function + -- - Extract variable + -- - Extract interface from class + -- - ... + CodeActionRefactorExtract + | -- | Base kind for refactoring inline actions: @refactor.inline@. + -- + -- Example inline actions: + -- + -- - Inline function + -- - Inline variable + -- - Inline constant + -- - ... + CodeActionRefactorInline + | -- | Base kind for refactoring rewrite actions: @refactor.rewrite@. + -- + -- Example rewrite actions: + -- + -- - Convert JavaScript function to class + -- - Add or remove parameter + -- - Encapsulate field + -- - Make method static + -- - Move method to base class + -- - ... + CodeActionRefactorRewrite + | -- | Base kind for source actions: @source@. + -- + -- Source code actions apply to the entire file. + CodeActionSource + | -- | Base kind for an organize imports source action: @source.organizeImports@. + CodeActionSourceOrganizeImports + | CodeActionUnknown Text + deriving (Read, Show, Eq) instance ToJSON CodeActionKind where + toJSON CodeActionEmpty = String "" toJSON CodeActionQuickFix = String "quickfix" toJSON CodeActionRefactor = String "refactor" toJSON CodeActionRefactorExtract = String "refactor.extract" @@ -231,6 +74,7 @@ instance ToJSON CodeActionKind where toJSON (CodeActionUnknown s) = String s instance FromJSON CodeActionKind where + parseJSON (String "") = pure CodeActionEmpty parseJSON (String "quickfix") = pure CodeActionQuickFix parseJSON (String "refactor") = pure CodeActionRefactor parseJSON (String "refactor.extract") = pure CodeActionRefactorExtract @@ -240,85 +84,122 @@ instance FromJSON CodeActionKind where parseJSON (String "source.organizeImports") = pure CodeActionSourceOrganizeImports parseJSON (String s) = pure (CodeActionUnknown s) parseJSON _ = mempty - -data CodeActionContext = - CodeActionContext - { _diagnostics :: List Diagnostic - , only :: Maybe (List CodeActionKind) - } deriving (Read,Show,Eq) + +-- ------------------------------------- + +data CodeActionKindClientCapabilities = + CodeActionKindClientCapabilities + { -- | The code action kind values the client supports. When this + -- property exists the client also guarantees that it will + -- handle values outside its set gracefully and falls back + -- to a default value when unknown. + _valueSet :: List CodeActionKind + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CodeActionKindClientCapabilities + +instance Default CodeActionKindClientCapabilities where + def = CodeActionKindClientCapabilities (List allKinds) + where allKinds = [ CodeActionQuickFix + , CodeActionRefactor + , CodeActionRefactorExtract + , CodeActionRefactorInline + , CodeActionRefactorRewrite + , CodeActionSource + , CodeActionSourceOrganizeImports + ] + +data CodeActionLiteralSupport = + CodeActionLiteralSupport + { _codeActionKind :: CodeActionKindClientCapabilities -- ^ The code action kind is support with the following value set. + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CodeActionLiteralSupport + +data CodeActionClientCapabilities = CodeActionClientCapabilities + { -- | Whether code action supports dynamic registration. + _dynamicRegistration :: Maybe Bool, + -- | The client support code action literals as a valid response + -- of the `textDocument/codeAction` request. + -- Since 3.8.0 + _codeActionLiteralSupport :: Maybe CodeActionLiteralSupport, + -- | Whether code action supports the `isPreferred` property. Since LSP 3.15.0 + _isPreferredSupport :: Maybe Bool + } + deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CodeActionClientCapabilities + +-- ------------------------------------- + +makeExtendingDatatype "CodeActionOptions" [''WorkDoneProgressOptions] + [("_codeActionKinds", [t| Maybe (List CodeActionKind) |])] +deriveJSON lspOptions ''CodeActionOptions + +makeExtendingDatatype "CodeActionRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''CodeActionOptions + ] [] +deriveJSON lspOptions ''CodeActionRegistrationOptions + +-- ------------------------------------- + +-- | Contains additional diagnostic information about the context in which a +-- code action is run. +data CodeActionContext = CodeActionContext + { -- | An array of diagnostics known on the client side overlapping the range provided to the + -- @textDocument/codeAction@ request. They are provided so that the server knows which + -- errors are currently presented to the user for the given range. There is no guarantee + -- that these accurately reflect the error state of the resource. The primary parameter + -- to compute code actions is the provided range. + _diagnostics :: List Diagnostic + -- | Requested kind of actions to return. + -- + -- Actions not of this kind are filtered out by the client before being shown. So servers + -- can omit computing them. + , _only :: Maybe (List CodeActionKind) + } + deriving (Read, Show, Eq) deriveJSON lspOptions ''CodeActionContext - -data CodeActionParams = - CodeActionParams - { _textDocument :: TextDocumentIdentifier - , _range :: Range - , _context :: CodeActionContext - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) - +makeExtendingDatatype "CodeActionParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [ ("_textDocument", [t|TextDocumentIdentifier|]), + ("_range", [t|Range|]), + ("_context", [t|CodeActionContext|]) + ] deriveJSON lspOptions ''CodeActionParams +-- | A code action represents a change that can be performed in code, e.g. to fix a problem or +-- to refactor code. +-- +-- A CodeAction must set either '_edit' and/or a '_command'. If both are supplied, +-- the '_edit' is applied first, then the '_command' is executed. data CodeAction = - -- | A code action represents a change that can be performed in code, e.g. to fix a problem or - -- to refactor code. - -- - -- A CodeAction must set either '_edit' and/or a '_command'. If both are supplied, - -- the '_edit' is applied first, then the '_command' is executed. CodeAction - { _title :: Text -- ^ A short, human-readable, title for this code action. - , _kind :: Maybe CodeActionKind -- ^ The kind of the code action. Used to filter code actions. - , _diagnostics :: Maybe (List Diagnostic) -- ^ The diagnostics that this code action resolves. - , _edit :: Maybe WorkspaceEdit -- ^ The workspace edit this code action performs. - , _command :: Maybe Command -- ^ A command this code action executes. If a code action - -- provides an edit and a command, first the edit is - -- executed and then the command. - } deriving (Read,Show,Eq) - + { -- | A short, human-readable, title for this code action. + _title :: Text, + -- | The kind of the code action. Used to filter code actions. + _kind :: Maybe CodeActionKind, + -- | The diagnostics that this code action resolves. + _diagnostics :: Maybe (List Diagnostic), + -- | Marks this as a preferred action. Preferred actions are used by the `auto fix` command and can be targeted + -- by keybindings. + -- + -- A quick fix should be marked preferred if it properly addresses the underlying error. + -- A refactoring should be marked preferred if it is the most reasonable choice of actions to take. + -- + -- Since LSP 3.15.0 + _isPreferred :: Maybe Bool, + -- | The workspace edit this code action performs. + _edit :: Maybe WorkspaceEdit, + -- | A command this code action executes. If a code action + -- provides an edit and a command, first the edit is + -- executed and then the command. + _command :: Maybe Command + } + deriving (Read, Show, Eq) deriveJSON lspOptions ''CodeAction - -data CAResult = CACommand Command - | CACodeAction CodeAction - deriving (Read,Show,Eq) - -instance FromJSON CAResult where - parseJSON x = CACommand <$> parseJSON x <|> CACodeAction <$> parseJSON x - -instance ToJSON CAResult where - toJSON (CACommand x) = toJSON x - toJSON (CACodeAction x) = toJSON x - - --- --------------------------------------------------------------------- -{- -/** - * Code Action options. - */ -export interface CodeActionOptions { - /** - * CodeActionKinds that this server may return. - * - * The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server - * may list out every specific kind they provide. - */ - codeActionKinds?: CodeActionKind[]; -} --} - -data CodeActionOptions = - CodeActionOptions - { _codeActionKinds :: Maybe [CodeActionKind] - } deriving (Read,Show,Eq) - -deriveJSON (lspOptions { sumEncoding = UntaggedValue }) ''CodeActionOptions - -data CodeActionRegistrationOptions = - CodeActionRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _codeActionOptions :: CodeActionOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''CodeActionRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_codeActionOptions" - ] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 4d88a7902..f95f597f1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -65,9 +65,6 @@ makeFieldsNoPrefix ''OnTypeFormattingClientCapabilities makeFieldsNoPrefix ''DefinitionClientCapabilities makeFieldsNoPrefix ''TypeDefinitionClientCapabilities makeFieldsNoPrefix ''ImplementationClientCapabilities -makeFieldsNoPrefix ''CodeActionKindClientCapabilities -makeFieldsNoPrefix ''CodeActionLiteralSupport -makeFieldsNoPrefix ''CodeActionClientCapabilities makeFieldsNoPrefix ''CodeLensClientCapabilities makeFieldsNoPrefix ''DocumentLinkClientCapabilities makeFieldsNoPrefix ''ColorProviderClientCapabilities @@ -155,6 +152,11 @@ makeFieldsNoPrefix ''CompletionParams makeFieldsNoPrefix ''CompletionRegistrationOptions -- CodeActions +makeFieldsNoPrefix ''CodeActionKindClientCapabilities +makeFieldsNoPrefix ''CodeActionLiteralSupport +makeFieldsNoPrefix ''CodeActionClientCapabilities +makeFieldsNoPrefix ''CodeActionOptions +makeFieldsNoPrefix ''CodeActionRegistrationOptions makeFieldsNoPrefix ''CodeActionContext makeFieldsNoPrefix ''CodeActionParams makeFieldsNoPrefix ''CodeAction diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 9a2998c37..f3fd5e7a1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -22,6 +22,7 @@ import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Color +import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration @@ -140,6 +141,11 @@ type family MessageParams (m :: Method p t) :: Type where -- | Map a request method to the response payload type type family ResponseParams (m :: Method p Request) :: Type where +-- Even though the specification mentions that the result types are +-- @x | y | ... | null@, they don't actually need to be wrapped in a Maybe since +-- (we think) this is just to account for how the response field is always +-- nullable. I.e. if it is null, then the error field is set + -- Client -- General ResponseParams Initialize = InitializeResponseCapabilities @@ -150,20 +156,20 @@ type family ResponseParams (m :: Method p Request) :: Type where -- Sync/Document state ResponseParams TextDocumentWillSaveWaitUntil = List TextEdit -- Completion - ResponseParams TextDocumentCompletion = Maybe (List CompletionItem |? CompletionList) + ResponseParams TextDocumentCompletion = List CompletionItem |? CompletionList ResponseParams CompletionItemResolve = CompletionItem -- Language Queries - ResponseParams TextDocumentHover = Maybe Hover - ResponseParams TextDocumentSignatureHelp = Maybe SignatureHelp - ResponseParams TextDocumentDeclaration = Maybe (Location |? List Location |? List LocationLink) - ResponseParams TextDocumentDefinition = Maybe (Location |? List Location |? List LocationLink) - ResponseParams TextDocumentTypeDefinition = Maybe (Location |? List Location |? List LocationLink) - ResponseParams TextDocumentImplementation = Maybe (Location |? List Location |? List LocationLink) - ResponseParams TextDocumentReferences = Maybe (List Location) - ResponseParams TextDocumentDocumentHighlight = Maybe (List DocumentHighlight) - ResponseParams TextDocumentDocumentSymbol = Maybe (List DocumentSymbol |? List SymbolInformation) + ResponseParams TextDocumentHover = Hover + ResponseParams TextDocumentSignatureHelp = SignatureHelp + ResponseParams TextDocumentDeclaration = Location |? List Location |? List LocationLink + ResponseParams TextDocumentDefinition = Location |? List Location |? List LocationLink + ResponseParams TextDocumentTypeDefinition = Location |? List Location |? List LocationLink + ResponseParams TextDocumentImplementation = Location |? List Location |? List LocationLink + ResponseParams TextDocumentReferences = List Location + ResponseParams TextDocumentDocumentHighlight = List DocumentHighlight + ResponseParams TextDocumentDocumentSymbol = List DocumentSymbol |? List SymbolInformation -- Code Action/Lens/Link - ResponseParams TextDocumentCodeAction = List CAResult + ResponseParams TextDocumentCodeAction = List (Command |? CodeAction) ResponseParams TextDocumentCodeLens = List CodeLens ResponseParams CodeLensResolve = CodeLens ResponseParams TextDocumentDocumentLink = List DocumentLink From c61ba3ef6e13669dabfb8f654b88cbf416e74f21 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 14:20:32 +0100 Subject: [PATCH 14/63] Update codeLens and codeLens resolve --- .../Haskell/LSP/Types/ClientCapabilities.hs | 11 +- .../Language/Haskell/LSP/Types/CodeLens.hs | 176 ++++-------------- .../src/Language/Haskell/LSP/Types/Lens.hs | 12 +- 3 files changed, 45 insertions(+), 154 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index c417ec63a..36748453f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -7,6 +7,7 @@ import Data.Aeson.TH import qualified Data.Aeson as A import Data.Default import Language.Haskell.LSP.Types.CodeAction +import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.Declaration @@ -671,16 +672,6 @@ data OnTypeFormattingClientCapabilities = deriveJSON lspOptions ''OnTypeFormattingClientCapabilities - --- ------------------------------------- - -data CodeLensClientCapabilities = - CodeLensClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''CodeLensClientCapabilities - -- ------------------------------------- data DocumentLinkClientCapabilities = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs index 6a02ef2bc..935974446 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs @@ -11,156 +11,54 @@ import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils -{- +-- ------------------------------------- -The code lens request is sent from the client to the server to compute code lenses for a given text document. - -Client Capability: - -property name (optional): textDocument.codeLens -property type: CodeLensClientCapabilities defined as follows: -export interface CodeLensClientCapabilities { - /** - * Whether code lens supports dynamic registration. - */ - dynamicRegistration?: boolean; -} -Server Capability: - -property name (optional): codeLensProvider -property type: CodeLensOptions defined as follows: -export interface CodeLensOptions extends WorkDoneProgressOptions { - /** - * Code lens has a resolve provider as well. - */ - resolveProvider?: boolean; -} -Registration Options: CodeLensRegistrationOptions defined as follows: - -export interface CodeLensRegistrationOptions extends TextDocumentRegistrationOptions, CodeLensOptions { -} -Request: - -method: ‘textDocument/codeLens’ -params: CodeLensParams defined as follows: -interface CodeLensParams extends WorkDoneProgressParams, PartialResultParams { - /** - * The document to request code lens for. - */ - textDocument: TextDocumentIdentifier; -} -Response: +data CodeLensClientCapabilities = + CodeLensClientCapabilities + { -- | Whether code lens supports dynamic registration. + _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) -result: CodeLens[] | null defined as follows: -/** - * A code lens represents a command that should be shown along with - * source text, like the number of references, a way to run tests, etc. - * - * A code lens is _unresolved_ when no command is associated to it. For performance - * reasons the creation of a code lens and resolving should be done in two stages. - */ -interface CodeLens { - /** - * The range in which this code lens is valid. Should only span a single line. - */ - range: Range; +deriveJSON lspOptions ''CodeLensClientCapabilities - /** - * The command this code lens represents. - */ - command?: Command; +-- ------------------------------------- - /** - * A data entry field that is preserved on a code lens item between - * a code lens and a code lens resolve request. - */ - data?: any -} -partial result: CodeLens[] -error: code and message set in case an exception happens during the code lens request. +makeExtendingDatatype "CodeLensOptions" [''WorkDoneProgressOptions] + [ ("_resolveProvider", [t| Maybe Bool |] )] +deriveJSON lspOptions ''CodeLensOptions --} +makeExtendingDatatype "CodeLensRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''CodeLensOptions + ] [] +deriveJSON lspOptions ''CodeLensRegistrationOptions -data CodeLensParams = - CodeLensParams - { _textDocument :: TextDocumentIdentifier - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) +-- ------------------------------------- +makeExtendingDatatype "CodeLensParams" + [ ''WorkDoneProgressParams, + ''PartialResultParams + ] + [("_textDocument", [t|TextDocumentIdentifier|])] deriveJSON lspOptions ''CodeLensParams +-- ------------------------------------- --- --------------------------------------------------------------------- - - +-- | A code lens represents a command that should be shown along with source +-- text, like the number of references, a way to run tests, etc. +-- +-- A code lens is _unresolved_ when no command is associated to it. For +-- performance reasons the creation of a code lens and resolving should be done +-- in two stages. data CodeLens = CodeLens - { _range :: Range - , _command :: Maybe Command - , _xdata :: Maybe Value - } deriving (Read,Show,Eq) + { -- | The range in which this code lens is valid. Should only span a single line. + _range :: Range + , -- | The command this code lens represents. + _command :: Maybe Command + , -- | A data entry field that is preserved on a code lens item between + -- a code lens and a code lens resolve request. + _xdata :: Maybe Value + } deriving (Read,Show,Eq) deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens - - --- --------------------------------------------------------------------- -{- -/** - * Code Lens options. - */ -export interface CodeLensOptions extends WorkDoneProgressOptions { - /** - * Code lens has a resolve provider as well. - */ - resolveProvider?: boolean; -} --} - -data CodeLensOptions = - CodeLensOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - -- | Code lens has a resolve provider as well. - , _resolveProvider :: Maybe Bool - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''CodeLensOptions [ "_workDoneProgressOptions" ] - -{- -Registration Options: CodeLensRegistrationOptions defined as follows: - -export interface CodeLensRegistrationOptions extends TextDocumentRegistrationOptions, CodeLensOptions { -} --} - -data CodeLensRegistrationOptions = - CodeLensRegistrationOptions - { _documentSelector :: TextDocumentRegistrationOptions - , _codeLensOptions :: CodeLensOptions - } deriving (Show, Read, Eq) - -deriveJSONExtendFields lspOptions ''CodeLensRegistrationOptions - [ "_documentSelector" - , "_codeLensOptions" - ] - --- --------------------------------------------------------------------- -{- -Code Lens Resolve Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#code-lens-resolve-request - -The code lens resolve request is sent from the client to the server to resolve -the command for a given code lens item. - -Request - - method: 'codeLens/resolve' - params: CodeLens - -Response - - result: CodeLens - error: code and message set in case an exception happens during the code - lens resolve request. - - --} diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index f95f597f1..86bc76fb5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -65,7 +65,6 @@ makeFieldsNoPrefix ''OnTypeFormattingClientCapabilities makeFieldsNoPrefix ''DefinitionClientCapabilities makeFieldsNoPrefix ''TypeDefinitionClientCapabilities makeFieldsNoPrefix ''ImplementationClientCapabilities -makeFieldsNoPrefix ''CodeLensClientCapabilities makeFieldsNoPrefix ''DocumentLinkClientCapabilities makeFieldsNoPrefix ''ColorProviderClientCapabilities makeFieldsNoPrefix ''RenameClientCapabilities @@ -80,7 +79,6 @@ makeFieldsNoPrefix ''InitializeParams makeFieldsNoPrefix ''InitializeError makeFieldsNoPrefix ''CompletionOptions makeFieldsNoPrefix ''SignatureHelpOptions -makeFieldsNoPrefix ''CodeLensOptions makeFieldsNoPrefix ''DocumentOnTypeFormattingOptions makeFieldsNoPrefix ''DocumentLinkOptions makeFieldsNoPrefix ''ExecuteCommandOptions @@ -120,9 +118,6 @@ makeFieldsNoPrefix ''SignatureHelpRegistrationOptions makeFieldsNoPrefix ''ReferenceContext makeFieldsNoPrefix ''ReferenceParams makeFieldsNoPrefix ''WorkspaceSymbolParams -makeFieldsNoPrefix ''CodeLensParams -makeFieldsNoPrefix ''CodeLens -makeFieldsNoPrefix ''CodeLensRegistrationOptions makeFieldsNoPrefix ''DocumentLinkParams makeFieldsNoPrefix ''DocumentLink makeFieldsNoPrefix ''FormattingOptions @@ -161,6 +156,13 @@ makeFieldsNoPrefix ''CodeActionContext makeFieldsNoPrefix ''CodeActionParams makeFieldsNoPrefix ''CodeAction +-- CodeLens +makeFieldsNoPrefix ''CodeLensClientCapabilities +makeFieldsNoPrefix ''CodeLensOptions +makeFieldsNoPrefix ''CodeLensRegistrationOptions +makeFieldsNoPrefix ''CodeLensParams +makeFieldsNoPrefix ''CodeLens + -- DocumentHighlight makeFieldsNoPrefix ''DocumentHighlightClientCapabilities makeFieldsNoPrefix ''DocumentHighlightOptions From 00c9f17e7b3b5061a5c8d1f5f0e908fefd476d5f Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 14:51:47 +0100 Subject: [PATCH 15/63] Update documentLink and documentLink resolve --- haskell-lsp-types/haskell-lsp-types.cabal | 1 + .../src/Language/Haskell/LSP/Types.hs | 2 + .../Haskell/LSP/Types/Capabilities.hs | 4 +- .../Haskell/LSP/Types/ClientCapabilities.hs | 10 +- .../Language/Haskell/LSP/Types/CodeLens.hs | 2 +- .../Language/Haskell/LSP/Types/Completion.hs | 2 +- .../Haskell/LSP/Types/DataTypesJSON.hs | 92 +------------------ .../Haskell/LSP/Types/DocumentLink.hs | 70 ++++++++++++++ .../src/Language/Haskell/LSP/Types/Lens.hs | 12 ++- .../src/Language/Haskell/LSP/Types/Message.hs | 3 +- .../Language/Haskell/LSP/Types/Progress.hs | 6 +- .../Haskell/LSP/Types/Registration.hs | 2 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 34 +------ .../src/Language/Haskell/LSP/Types/Utils.hs | 17 ++-- .../src/Language/Haskell/LSP/Types/Window.hs | 6 +- 15 files changed, 107 insertions(+), 156 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentLink.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index b7169e84a..a77d86606 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -34,6 +34,7 @@ library , Language.Haskell.LSP.Types.Diagnostic , Language.Haskell.LSP.Types.DocumentFilter , Language.Haskell.LSP.Types.DocumentHighlight + , Language.Haskell.LSP.Types.DocumentLink , Language.Haskell.LSP.Types.FoldingRange , Language.Haskell.LSP.Types.Formatting , Language.Haskell.LSP.Types.Hover diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index edf673398..f933bd51b 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -11,6 +11,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Diagnostic , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.DocumentHighlight + , module Language.Haskell.LSP.Types.DocumentLink , module Language.Haskell.LSP.Types.Empty , module Language.Haskell.LSP.Types.FoldingRange , module Language.Haskell.LSP.Types.Formatting @@ -49,6 +50,7 @@ import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 3494581f7..4aba8679a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -13,7 +13,7 @@ import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types -- | The whole shebang. The real deal. --- Capabilities for full conformance to the current (v3.10) LSP specification. +-- Capabilities for full conformance to the current (v3.15) LSP specification. fullCaps :: ClientCapabilities fullCaps = capsForVersion (LSPVersion maxBound maxBound) @@ -103,7 +103,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (since 3 6 (ImplementationClientCapabilities dynamicReg (since 3 14 True))) (Just codeActionCapability) (Just (CodeLensClientCapabilities dynamicReg)) - (Just (DocumentLinkClientCapabilities dynamicReg)) + (Just (DocumentLinkClientCapabilities dynamicReg (since 3 15 True))) (since 3 6 (ColorProviderClientCapabilities dynamicReg)) (Just (RenameClientCapabilities dynamicReg (since 3 12 True))) (Just publishDiagnosticsCapabilities) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 36748453f..11657222a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -13,6 +13,7 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Hover @@ -674,15 +675,6 @@ deriveJSON lspOptions ''OnTypeFormattingClientCapabilities -- ------------------------------------- -data DocumentLinkClientCapabilities = - DocumentLinkClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DocumentLinkClientCapabilities - --- ------------------------------------- - data ColorProviderClientCapabilities = ColorProviderClientCapabilities { -- | Whether colorProvider supports dynamic registration. If this is set to `true` diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs index 935974446..02a66cd8f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/CodeLens.hs @@ -61,4 +61,4 @@ data CodeLens = _xdata :: Maybe Value } deriving (Read,Show,Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens +deriveJSON lspOptions ''CodeLens diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs index b1a5dbc7f..a6e112a50 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs @@ -264,7 +264,7 @@ data CompletionItem = -- completion resolve request. } deriving (Read,Show,Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CompletionItem +deriveJSON lspOptions ''CompletionItem -- | Represents a collection of 'CompletionItem's to be presented in the editor. data CompletionList = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index 16358e573..2c19e1028 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -950,7 +950,7 @@ data FileEvent = , _xtype :: FileChangeType } deriving (Read,Show,Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''FileEvent +deriveJSON lspOptions ''FileEvent data DidChangeWatchedFilesParams = DidChangeWatchedFilesParams @@ -1097,96 +1097,6 @@ makeExtendingDatatype "WorkspaceSymbolParams" [''WorkDoneProgressParams, ''Parti deriveJSON lspOptions ''WorkspaceSymbolParams - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -Document Link Request - -The document links request is sent from the client to the server to request the -location of links in a document. - -Request: - - method: 'textDocument/documentLink' - params: DocumentLinkParams, defined as follows - -interface DocumentLinkParams { - /** - * The document to provide document links for. - */ - textDocument: TextDocumentIdentifier; -} - -Response: - - result: An array of DocumentLink, or null. - -/** - * A document link is a range in a text document that links to an internal or external resource, like another - * text document or a web site. - */ -interface DocumentLink { - /** - * The range this link applies to. - */ - range: Range; - /** - * The uri this link points to. If missing a resolve request is sent later. - */ - target?: DocumentUri; -} - - error: code and message set in case an exception happens during the document link request. - -Registration Options: DocumentLinkRegistrationOptions defined as follows: - -export interface DocumentLinkRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * Document links have a resolve provider as well. - */ - resolveProvider?: boolean; -} --} - -data DocumentLinkParams = - DocumentLinkParams - { _textDocument :: TextDocumentIdentifier - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DocumentLinkParams - -data DocumentLink = - DocumentLink - { _range :: Range - , _target :: Maybe Text - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DocumentLink --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -Document Link Resolve Request - -The document link resolve request is sent from the client to the server to resolve the target of a given document link. - -Request: - - method: 'documentLink/resolve' - params: DocumentLink - -Response: - - result: DocumentLink - error: code and message set in case an exception happens during the document link resolve request. - --} - -- --------------------------------------------------------------------- {- New in 3.0 diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentLink.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentLink.hs new file mode 100644 index 000000000..8a8532a27 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentLink.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Language.Haskell.LSP.Types.DocumentLink where + +import Data.Aeson +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.Utils + +data DocumentLinkClientCapabilities = + DocumentLinkClientCapabilities + { -- | Whether document link supports dynamic registration. + _dynamicRegistration :: Maybe Bool + -- | Whether the client supports the `tooltip` property on `DocumentLink`. + -- + -- Since LSP 3.15.0 + , _tooltipSupport :: Maybe Bool + } deriving (Read, Show, Eq) +deriveJSON lspOptions ''DocumentLinkClientCapabilities + +-- ------------------------------------- + +makeExtendingDatatype "DocumentLinkOptions" [''WorkDoneProgressOptions] + [("_resolveProvider", [t| Maybe Bool |])] +deriveJSON lspOptions ''DocumentLinkOptions + +makeExtendingDatatype "DocumentLinkRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''DocumentLinkOptions + ] [] +deriveJSON lspOptions ''DocumentLinkRegistrationOptions + +-- ------------------------------------- + +makeExtendingDatatype "DocumentLinkParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [("_textDocument", [t| TextDocumentIdentifier |])] +deriveJSON lspOptions ''DocumentLinkParams + +-- ------------------------------------- + +-- | A document link is a range in a text document that links to an internal or +-- external resource, like another text document or a web site. +data DocumentLink = + DocumentLink + { -- | The range this link applies to. + _range :: Range + -- | The uri this link points to. If missing a resolve request is sent + -- later. + , _target :: Maybe Uri + -- | The tooltip text when you hover over this link. + -- + -- If a tooltip is provided, is will be displayed in a string that includes + -- instructions on how to trigger the link, such as @{0} (ctrl + click)@. + -- The specific instructions vary depending on OS, user settings, and + -- localization. + -- + -- Since LSP 3.15.0 + , _tooltip :: Maybe String + -- | A data entry field that is preserved on a document link between a + -- DocumentLinkRequest and a DocumentLinkResolveRequest. + , _xdata :: Maybe Value + } deriving (Read, Show, Eq) +deriveJSON lspOptions ''DocumentLink diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 86bc76fb5..7824353fa 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -19,6 +19,7 @@ import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover @@ -65,7 +66,6 @@ makeFieldsNoPrefix ''OnTypeFormattingClientCapabilities makeFieldsNoPrefix ''DefinitionClientCapabilities makeFieldsNoPrefix ''TypeDefinitionClientCapabilities makeFieldsNoPrefix ''ImplementationClientCapabilities -makeFieldsNoPrefix ''DocumentLinkClientCapabilities makeFieldsNoPrefix ''ColorProviderClientCapabilities makeFieldsNoPrefix ''RenameClientCapabilities makeFieldsNoPrefix ''PublishDiagnosticsClientCapabilities @@ -80,7 +80,6 @@ makeFieldsNoPrefix ''InitializeError makeFieldsNoPrefix ''CompletionOptions makeFieldsNoPrefix ''SignatureHelpOptions makeFieldsNoPrefix ''DocumentOnTypeFormattingOptions -makeFieldsNoPrefix ''DocumentLinkOptions makeFieldsNoPrefix ''ExecuteCommandOptions makeFieldsNoPrefix ''SaveOptions makeFieldsNoPrefix ''TextDocumentSyncOptions @@ -118,8 +117,6 @@ makeFieldsNoPrefix ''SignatureHelpRegistrationOptions makeFieldsNoPrefix ''ReferenceContext makeFieldsNoPrefix ''ReferenceParams makeFieldsNoPrefix ''WorkspaceSymbolParams -makeFieldsNoPrefix ''DocumentLinkParams -makeFieldsNoPrefix ''DocumentLink makeFieldsNoPrefix ''FormattingOptions makeFieldsNoPrefix ''DocumentFormattingParams makeFieldsNoPrefix ''DocumentRangeFormattingParams @@ -163,6 +160,13 @@ makeFieldsNoPrefix ''CodeLensRegistrationOptions makeFieldsNoPrefix ''CodeLensParams makeFieldsNoPrefix ''CodeLens +-- DocumentLink +makeFieldsNoPrefix ''DocumentLinkClientCapabilities +makeFieldsNoPrefix ''DocumentLinkOptions +makeFieldsNoPrefix ''DocumentLinkRegistrationOptions +makeFieldsNoPrefix ''DocumentLinkParams +makeFieldsNoPrefix ''DocumentLink + -- DocumentHighlight makeFieldsNoPrefix ''DocumentHighlightClientCapabilities makeFieldsNoPrefix ''DocumentHighlightOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index f3fd5e7a1..b0d2e4747 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -28,6 +28,7 @@ import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting @@ -377,7 +378,7 @@ data ResponseError = , _xdata :: Maybe Value } deriving (Read,Show,Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ResponseError +deriveJSON lspOptions ''ResponseError -- | Either result or error must be Just. data ResponseMessage (m :: Method p Request) = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs index c0646ece6..ba7d3c421 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs @@ -82,7 +82,7 @@ data ProgressParams t = , _value :: t } deriving (Show, Read, Eq, Functor) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ProgressParams +deriveJSON lspOptions ''ProgressParams data SomeProgressParams = Begin WorkDoneProgressBeginParams @@ -305,7 +305,7 @@ data WorkDoneProgressCancelParams = _token :: ProgressToken } deriving (Show, Read, Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressCancelParams +deriveJSON lspOptions ''WorkDoneProgressCancelParams -- | The window/workDoneProgress/cancel notification is sent from the client to the server -- to inform the server that the user has pressed the cancel button on the progress UX. @@ -318,7 +318,7 @@ data WorkDoneProgressCreateParams = _token :: ProgressToken } deriving (Show, Read, Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''WorkDoneProgressCreateParams +deriveJSON lspOptions ''WorkDoneProgressCreateParams data WorkDoneProgressOptions = WorkDoneProgressOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index 233db3f8f..3faa0a3a3 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -38,7 +38,7 @@ import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight -import Language.Haskell.LSP.Types.ServerCapabilities +import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 341c68565..f021eee69 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -17,6 +17,7 @@ import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight +import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover @@ -25,7 +26,6 @@ import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.DocumentSymbol -import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils @@ -294,38 +294,6 @@ instance ToJSON TDS where toJSON (TDSKind x) = toJSON x -- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -/** - * Document link options - */ -export interface DocumentLinkOptions { - /** - * Document links have a resolve provider as well. - */ - resolveProvider?: boolean; -} --} - -data DocumentLinkOptions = - DocumentLinkOptions - { -- | Document links have a resolve provider as well. - _resolveProvider :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DocumentLinkOptions - -data DocumentLinkRegistrationOptions = - DocumentLinkRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _documentLinkOptions :: DocumentLinkOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentLinkRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_documentLinkOptions" - ] data WorkspaceFoldersServerCapabilities = WorkspaceFoldersServerCapabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs index f11ae93e1..204076b18 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs @@ -9,7 +9,6 @@ module Language.Haskell.LSP.Types.Utils , makeRegHelper , makeExtendingDatatype , lspOptions - , customModifier ) where import Language.Haskell.TH @@ -187,11 +186,15 @@ makeExtendingDatatype datatypeNameStr extends fields = do (\a -> [a]) <$> dataD (cxt []) datatypeName [] Nothing [constructor] derivs -- | Standard options for use when generating JSON instances +-- NOTE: This needs to be in a separate file because of the TH stage restriction lspOptions :: Options -lspOptions = defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1 } - -- NOTE: This needs to be in a separate file because of the TH stage restriction +lspOptions = defaultOptions { omitNothingFields = True, fieldLabelModifier = modifier } + where + modifier :: String -> String + -- For fields called data and type in the spec, we call them xdata and xtype + -- in haskell-lsp-types to avoid it clashing with the Haskell keywords. This + -- fixes up the json derivation + modifier "_xdata" = "data" + modifier "_xtype" = "type" + modifier xs = drop 1 xs -customModifier :: String -> String -customModifier "_xdata" = "data" -customModifier "_xtype" = "type" -customModifier xs = drop 1 xs diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs index eb4b87fd3..bd1fe52e4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs @@ -84,7 +84,7 @@ data ShowMessageParams = , _message :: Text } deriving (Show, Read, Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageParams +deriveJSON lspOptions ''ShowMessageParams -- --------------------------------------------------------------------- {- @@ -149,7 +149,7 @@ data ShowMessageRequestParams = , _actions :: Maybe [MessageActionItem] } deriving (Show,Read,Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageRequestParams +deriveJSON lspOptions ''ShowMessageRequestParams -- --------------------------------------------------------------------- {- @@ -186,4 +186,4 @@ data LogMessageParams = , _message :: Text } deriving (Show, Read, Eq) -deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''LogMessageParams +deriveJSON lspOptions ''LogMessageParams From b8d6c4034c44f0eb7604eb998ed5c8104c883f15 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 14:53:58 +0100 Subject: [PATCH 16/63] Remove empty module --- haskell-lsp-types/haskell-lsp-types.cabal | 1 - haskell-lsp-types/src/Language/Haskell/LSP/Types.hs | 2 -- .../src/Language/Haskell/LSP/Types/Common.hs | 7 +++++++ .../src/Language/Haskell/LSP/Types/Empty.hs | 10 ---------- .../src/Language/Haskell/LSP/Types/Message.hs | 1 - .../src/Language/Haskell/LSP/Types/Registration.hs | 1 - 6 files changed, 7 insertions(+), 15 deletions(-) delete mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index a77d86606..bf18f9cc3 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -41,7 +41,6 @@ library , Language.Haskell.LSP.Types.Implementation , Language.Haskell.LSP.Types.Location , Language.Haskell.LSP.Types.LspId - , Language.Haskell.LSP.Types.Empty , Language.Haskell.LSP.Types.MarkupContent , Language.Haskell.LSP.Types.Method , Language.Haskell.LSP.Types.Message diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index f933bd51b..2aa59b84c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -12,7 +12,6 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.DocumentHighlight , module Language.Haskell.LSP.Types.DocumentLink - , module Language.Haskell.LSP.Types.Empty , module Language.Haskell.LSP.Types.FoldingRange , module Language.Haskell.LSP.Types.Formatting , module Language.Haskell.LSP.Types.Hover @@ -51,7 +50,6 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink -import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index 8c0e7df33..cd72dfe6f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -44,3 +44,10 @@ instance (FromJSON a) => FromJSON (List a) where instance Semigroup (List a) where (<>) = mappend #endif + +data Empty = Empty deriving (Eq,Ord,Show) +instance ToJSON Empty where + toJSON Empty = Null +instance FromJSON Empty where + parseJSON Null = pure Empty + parseJSON _ = mempty diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs deleted file mode 100644 index f24b54a85..000000000 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Empty.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Language.Haskell.LSP.Types.Empty where - -import Data.Aeson - -data Empty = Empty deriving (Eq,Ord,Show) -instance ToJSON Empty where - toJSON Empty = Null -instance FromJSON Empty where - parseJSON Null = pure Empty - parseJSON _ = mempty diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index b0d2e4747..a0c80c5c1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -29,7 +29,6 @@ import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink -import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index 3faa0a3a3..a6f3c8ba7 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -39,7 +39,6 @@ import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink -import Language.Haskell.LSP.Types.Empty import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover From d2a67e53b485f40f2a505b802b586de6cf95c1fa Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 14:54:57 +0100 Subject: [PATCH 17/63] Replace TDS wrapper with |? --- .../Haskell/LSP/Types/ServerCapabilities.hs | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index f021eee69..1fde678ba 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -281,18 +281,6 @@ interface ServerCapabilities { } -} --- | Wrapper for TextDocumentSyncKind fallback. -data TDS = TDSOptions TextDocumentSyncOptions - | TDSKind TextDocumentSyncKind - deriving (Show, Read, Eq) - -instance FromJSON TDS where - parseJSON x = TDSOptions <$> parseJSON x <|> TDSKind <$> parseJSON x - -instance ToJSON TDS where - toJSON (TDSOptions x) = toJSON x - toJSON (TDSKind x) = toJSON x - -- --------------------------------------------------------------------- data WorkspaceFoldersServerCapabilities = @@ -327,7 +315,7 @@ data ServerCapabilities = -- defining each notification or for backwards compatibility the -- 'TextDocumentSyncKind' number. -- If omitted it defaults to 'TdSyncNone'. - _textDocumentSync :: Maybe TDS + _textDocumentSync :: Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind) -- | The server provides hover support. , _hoverProvider :: Maybe (Bool |? HoverOptions) -- | The server provides completion support. From 85fdc3432d455fa42a2f5927411ffe90d828b725 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 15:42:32 +0100 Subject: [PATCH 18/63] Update documentColor and colorPresentation --- haskell-lsp-types/haskell-lsp-types.cabal | 2 +- .../src/Language/Haskell/LSP/Types.hs | 4 +- .../src/Language/Haskell/LSP/Types/Color.hs | 212 ------------------ .../Haskell/LSP/Types/DocumentColor.hs | 91 ++++++++ .../src/Language/Haskell/LSP/Types/Lens.hs | 21 +- .../src/Language/Haskell/LSP/Types/Message.hs | 2 +- .../Haskell/LSP/Types/Registration.hs | 2 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 3 +- 8 files changed, 110 insertions(+), 227 deletions(-) delete mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentColor.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index bf18f9cc3..e77fa33ac 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -24,7 +24,6 @@ library other-modules: Language.Haskell.LSP.Types.ClientCapabilities , Language.Haskell.LSP.Types.CodeAction , Language.Haskell.LSP.Types.CodeLens - , Language.Haskell.LSP.Types.Color , Language.Haskell.LSP.Types.Command , Language.Haskell.LSP.Types.Common , Language.Haskell.LSP.Types.Completion @@ -32,6 +31,7 @@ library , Language.Haskell.LSP.Types.Declaration , Language.Haskell.LSP.Types.Definition , Language.Haskell.LSP.Types.Diagnostic + , Language.Haskell.LSP.Types.DocumentColor , Language.Haskell.LSP.Types.DocumentFilter , Language.Haskell.LSP.Types.DocumentHighlight , Language.Haskell.LSP.Types.DocumentLink diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 2aa59b84c..070c0ca20 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -2,13 +2,13 @@ module Language.Haskell.LSP.Types ( module Language.Haskell.LSP.Types.DataTypesJSON , module Language.Haskell.LSP.Types.CodeAction , module Language.Haskell.LSP.Types.CodeLens - , module Language.Haskell.LSP.Types.Color , module Language.Haskell.LSP.Types.Command , module Language.Haskell.LSP.Types.Common , module Language.Haskell.LSP.Types.Completion , module Language.Haskell.LSP.Types.Declaration , module Language.Haskell.LSP.Types.Definition , module Language.Haskell.LSP.Types.Diagnostic + , module Language.Haskell.LSP.Types.DocumentColor , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.DocumentHighlight , module Language.Haskell.LSP.Types.DocumentLink @@ -40,13 +40,13 @@ where import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens -import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic +import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs deleted file mode 100644 index b5cbd20d7..000000000 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Color.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE TemplateHaskell #-} -module Language.Haskell.LSP.Types.Color where - -import Data.Aeson.TH -import Data.Text ( Text ) -import Language.Haskell.LSP.Types.Common -import Language.Haskell.LSP.Types.Location -import Language.Haskell.LSP.Types.Progress -import Language.Haskell.LSP.Types.StaticRegistrationOptions -import Language.Haskell.LSP.Types.TextDocument -import Language.Haskell.LSP.Types.WorkspaceEdit -import Language.Haskell.LSP.Types.Utils - -{- -Document Color Request (:leftwards_arrow_with_hook:) -Since version 3.6.0 - -The document color request is sent from the client to the server to list all -color references found in a given text document. Along with the range, a color -value in RGB is returned. - -Clients can use the result to decorate color references in an editor. For example: - -Color boxes showing the actual color next to the reference -Show a color picker when a color reference is edited -Request: - -method: ‘textDocument/documentColor’ -params: DocumentColorParams defined as follows -interface DocumentColorParams { - /** - * The text document. - */ - textDocument: TextDocumentIdentifier; -} -Response: - -result: ColorInformation[] defined as follows: -interface ColorInformation { - /** - * The range in the document where this color appears. - */ - range: Range; - - /** - * The actual color value for this color range. - */ - color: Color; -} - -/** - * Represents a color in RGBA space. - */ -interface Color { - - /** - * The red component of this color in the range [0-1]. - */ - readonly red: number; - - /** - * The green component of this color in the range [0-1]. - */ - readonly green: number; - - /** - * The blue component of this color in the range [0-1]. - */ - readonly blue: number; - - /** - * The alpha component of this color in the range [0-1]. - */ - readonly alpha: number; -} -error: code and message set in case an exception happens during the -‘textDocument/documentColor’ request --} - --- | Represents a color in RGBA space. -data Color = - Color - { _red :: Int -- ^ The red component of this color in the range [0-1]. - , _green :: Int -- ^ The green component of this color in the range [0-1]. - , _blue :: Int -- ^ The blue component of this color in the range [0-1]. - , _alpha :: Int -- ^ The alpha component of this color in the range [0-1]. - } deriving (Read, Show, Eq) - -deriveJSON lspOptions ''Color - -data ColorInformation = - ColorInformation - { _range :: Range -- ^ The range in the document where this color appears. - , _color :: Color -- ^ The actual color value for this color range. - } deriving (Read, Show, Eq) - -deriveJSON lspOptions ''ColorInformation - -data DocumentColorParams = - DocumentColorParams - { _textDocument :: TextDocumentIdentifier -- ^ The text document. - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read, Show, Eq) - -deriveJSON lspOptions ''DocumentColorParams - -{- -Color Presentation Request (:leftwards_arrow_with_hook:) -Since version 3.6.0 - -The color presentation request is sent from the client to the server to obtain a list of -presentations for a color value at a given location. Clients can use the result to - -modify a color reference. -show in a color picker and let users pick one of the presentations -Request: - -method: ‘textDocument/colorPresentation’ -params: DocumentColorParams defined as follows -interface ColorPresentationParams { - /** - * The text document. - */ - textDocument: TextDocumentIdentifier; - - /** - * The color information to request presentations for. - */ - color: Color; - - /** - * The range where the color would be inserted. Serves as a context. - */ - range: Range; -} -Response: - -result: ColorPresentation[] defined as follows: -interface ColorPresentation { - /** - * The label of this color presentation. It will be shown - * on the color picker header. By default this is also the - * text that is inserted when selecting - * this color presentation. - */ - label: string; - /** - * An [edit](#TextEdit) which is applied to a document when selecting - * this presentation for the color. - * When `falsy` the [label](#ColorPresentation.label) is used. - */ - textEdit?: TextEdit; - /** - * An optional array of additional [text edits](#TextEdit) that are applied when - * selecting this color presentation. Edits must not overlap with the main - * [edit](#ColorPresentation.textEdit) nor with themselves. - */ - additionalTextEdits?: TextEdit[]; -} -error: code and message set in case an exception happens during the -‘textDocument/colorPresentation’ request --} - -data ColorPresentationParams = - ColorPresentationParams - { -- | The text document. - _textDocument :: TextDocumentIdentifier - -- | The color information to request presentations for. - , _color :: Color - -- | The range where the color would be inserted. - -- Serves as a context. - , _range :: Range - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read, Show, Eq) - -deriveJSON lspOptions ''ColorPresentationParams - -data ColorPresentation = - ColorPresentation - { -- | The label of this color presentation. It will be shown on the color - -- picker header. By default this is also the text that is inserted when selecting - -- this color presentation. - _label :: Text - -- | A 'TextEdit' which is applied to a document when selecting - -- this presentation for the color. When `falsy` the '_label' - -- is used. - , _textEdit :: Maybe TextEdit - -- | An optional array of additional 'TextEdit's that are applied when - -- selecting this color presentation. Edits must not overlap with the main - -- '_textEdit' nor with themselves. - , _additionalTextEdits :: Maybe (List TextEdit) - } deriving (Read, Show, Eq) - -deriveJSON lspOptions ''ColorPresentation - -data DocumentColorOptions = - DocumentColorOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentColorOptions ["_workDoneProgressOptions"] - -data DocumentColorRegistrationOptions = - DocumentColorRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _staticRegistrationOptions :: StaticRegistrationOptions - , _documentColorOptions :: DocumentColorOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentColorRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_staticRegistrationOptions" - , "_documentColorOptions"] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentColor.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentColor.hs new file mode 100644 index 000000000..827367076 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentColor.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +module Language.Haskell.LSP.Types.DocumentColor where + +import Data.Aeson.TH +import Data.Text (Text) +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.StaticRegistrationOptions +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils +import Language.Haskell.LSP.Types.WorkspaceEdit + +data DocumentColorClientCapabilities = + DocumentColorClientCapabilities + { -- | Whether document color supports dynamic registration. + _dynamicRegistration :: Maybe Bool + } deriving (Read, Show, Eq) +deriveJSON lspOptions ''DocumentColorClientCapabilities + +-- ------------------------------------- + +makeExtendingDatatype "DocumentColorOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''DocumentColorOptions + +makeExtendingDatatype "DocumentColorRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''StaticRegistrationOptions + , ''DocumentColorOptions + ] [] +deriveJSON lspOptions ''DocumentColorRegistrationOptions + +-- ------------------------------------- + +makeExtendingDatatype "DocumentColorParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [("_textDocument", [t| TextDocumentIdentifier |])] +deriveJSON lspOptions ''DocumentColorParams + +-- ------------------------------------- + +-- | Represents a color in RGBA space. +data Color = + Color + { _red :: Int -- ^ The red component of this color in the range [0-1]. + , _green :: Int -- ^ The green component of this color in the range [0-1]. + , _blue :: Int -- ^ The blue component of this color in the range [0-1]. + , _alpha :: Int -- ^ The alpha component of this color in the range [0-1]. + } deriving (Read, Show, Eq) +deriveJSON lspOptions ''Color + +data ColorInformation = + ColorInformation + { _range :: Range -- ^ The range in the document where this color appears. + , _color :: Color -- ^ The actual color value for this color range. + } deriving (Read, Show, Eq) +deriveJSON lspOptions ''ColorInformation + +-- ------------------------------------- + +makeExtendingDatatype "ColorPresentationParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [ ("_textDocument", [t| TextDocumentIdentifier |]) + , ("_color", [t| Color |]) + , ("_range", [t| Range |]) + ] +deriveJSON lspOptions ''ColorPresentationParams + +-- ------------------------------------- + +data ColorPresentation = + ColorPresentation + { -- | The label of this color presentation. It will be shown on the color + -- picker header. By default this is also the text that is inserted when selecting + -- this color presentation. + _label :: Text + -- | A 'TextEdit' which is applied to a document when selecting + -- this presentation for the color. When `falsy` the '_label' + -- is used. + , _textEdit :: Maybe TextEdit + -- | An optional array of additional 'TextEdit's that are applied when + -- selecting this color presentation. Edits must not overlap with the main + -- '_textEdit' nor with themselves. + , _additionalTextEdits :: Maybe (List TextEdit) + } deriving (Read, Show, Eq) +deriveJSON lspOptions ''ColorPresentation diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 7824353fa..fe9a08825 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -11,12 +11,12 @@ module Language.Haskell.LSP.Types.Lens where import Language.Haskell.LSP.Types.ClientCapabilities import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens -import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic +import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink @@ -167,6 +167,18 @@ makeFieldsNoPrefix ''DocumentLinkRegistrationOptions makeFieldsNoPrefix ''DocumentLinkParams makeFieldsNoPrefix ''DocumentLink +-- DocumentColor +makeFieldsNoPrefix ''DocumentColorClientCapabilities +makeFieldsNoPrefix ''DocumentColorOptions +makeFieldsNoPrefix ''DocumentColorRegistrationOptions +makeFieldsNoPrefix ''DocumentColorParams +makeFieldsNoPrefix ''Color +makeFieldsNoPrefix ''ColorInformation + +-- ColorPresentation +makeFieldsNoPrefix ''ColorPresentationParams +makeFieldsNoPrefix ''ColorPresentation + -- DocumentHighlight makeFieldsNoPrefix ''DocumentHighlightClientCapabilities makeFieldsNoPrefix ''DocumentHighlightOptions @@ -220,13 +232,6 @@ makeFieldsNoPrefix ''DiagnosticRelatedInformation makeFieldsNoPrefix ''Hover makeFieldsNoPrefix ''HoverRegistrationOptions --- Color -makeFieldsNoPrefix ''Color -makeFieldsNoPrefix ''ColorInformation -makeFieldsNoPrefix ''DocumentColorParams -makeFieldsNoPrefix ''ColorPresentationParams -makeFieldsNoPrefix ''ColorPresentation - -- Folding Range makeFieldsNoPrefix ''FoldingRange makeFieldsNoPrefix ''FoldingRangeParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index a0c80c5c1..da086132a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -21,12 +21,12 @@ module Language.Haskell.LSP.Types.Message where import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens -import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition +import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.FoldingRange diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index a6f3c8ba7..751122bf6 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -31,12 +31,12 @@ import Data.Void (Void) import GHC.Generics import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens -import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition +import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.FoldingRange diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 1fde678ba..12ed90158 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -4,18 +4,17 @@ module Language.Haskell.LSP.Types.ServerCapabilities where -import Control.Applicative import Data.Aeson import Data.Aeson.TH import Data.Text (Text) import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens -import Language.Haskell.LSP.Types.Color import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition +import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.FoldingRange From 52b5ff7073174164e82fc54685ab7b55d042611c Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 16:02:37 +0100 Subject: [PATCH 19/63] Update formatting rangeFormatting onTypeFormatting --- .../Haskell/LSP/Types/Capabilities.hs | 6 +- .../Haskell/LSP/Types/ClientCapabilities.hs | 37 +-- .../Language/Haskell/LSP/Types/Formatting.hs | 296 ++++-------------- .../src/Language/Haskell/LSP/Types/Lens.hs | 27 +- 4 files changed, 91 insertions(+), 275 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 4aba8679a..98017f100 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -94,9 +94,9 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (Just (ReferencesClientCapabilities dynamicReg)) (Just (DocumentHighlightClientCapabilities dynamicReg)) (Just documentSymbolCapability) - (Just (FormattingClientCapabilities (Just True))) - (Just (RangeFormattingClientCapabilities dynamicReg)) - (Just (OnTypeFormattingClientCapabilities dynamicReg)) + (Just (DocumentFormattingClientCapabilities dynamicReg)) + (Just (DocumentRangeFormattingClientCapabilities dynamicReg)) + (Just (DocumentOnTypeFormattingClientCapabilities dynamicReg)) (since 3 14 (DeclarationClientCapabilities dynamicReg (Just True))) (Just (DefinitionClientCapabilities dynamicReg (since 3 14 True))) (since 3 6 (TypeDefinitionClientCapabilities dynamicReg (since 3 14 True))) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 11657222a..efe3048cf 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -8,6 +8,7 @@ import qualified Data.Aeson as A import Data.Default import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.Declaration @@ -15,7 +16,7 @@ import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.DocumentSymbol -import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.SignatureHelp @@ -645,34 +646,6 @@ deriveJSON lspOptions ''SynchronizationTextDocumentClientCapabilities instance Default SynchronizationTextDocumentClientCapabilities where def = SynchronizationTextDocumentClientCapabilities def def def def - --- ------------------------------------- - -data FormattingClientCapabilities = - FormattingClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''FormattingClientCapabilities - --- ------------------------------------- - -data RangeFormattingClientCapabilities = - RangeFormattingClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''RangeFormattingClientCapabilities - --- ------------------------------------- - -data OnTypeFormattingClientCapabilities = - OnTypeFormattingClientCapabilities - { _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''OnTypeFormattingClientCapabilities - -- ------------------------------------- data ColorProviderClientCapabilities = @@ -763,13 +736,13 @@ data TextDocumentClientCapabilities = , _documentSymbol :: Maybe DocumentSymbolClientCapabilities -- | Capabilities specific to the `textDocument/formatting` - , _formatting :: Maybe FormattingClientCapabilities + , _formatting :: Maybe DocumentFormattingClientCapabilities -- | Capabilities specific to the `textDocument/rangeFormatting` - , _rangeFormatting :: Maybe RangeFormattingClientCapabilities + , _rangeFormatting :: Maybe DocumentRangeFormattingClientCapabilities -- | Capabilities specific to the `textDocument/onTypeFormatting` - , _onTypeFormatting :: Maybe OnTypeFormattingClientCapabilities + , _onTypeFormatting :: Maybe DocumentOnTypeFormattingClientCapabilities -- | Capabilities specific to the `textDocument/declaration` request. -- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs index 61cc76458..0e19cf190 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs @@ -9,243 +9,75 @@ import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils -{- -Document Formatting Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-formatting-request - -The document formatting request is sent from the server to the client to format -a whole document. - -Request - - method: 'textDocument/formatting' - params: DocumentFormattingParams defined as follows - -interface DocumentFormattingParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The format options. - */ - options: FormattingOptions; -} - -/** - * Value-object describing what options formatting should use. - */ -interface FormattingOptions { - /** - * Size of a tab in spaces. - */ - tabSize: number; - - /** - * Prefer spaces over tabs. - */ - insertSpaces: boolean; - - /** - * Signature for further properties. - */ - [key: string]: boolean | number | string; -} - -Response - - result: TextEdit[] describing the modification to the document to be - formatted. - error: code and message set in case an exception happens during the - formatting request. - -Registration Options: TextDocumentRegistrationOptions --} +data DocumentFormattingClientCapabilities = + DocumentFormattingClientCapabilities + { -- | Whether formatting supports dynamic registration. + _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''DocumentFormattingClientCapabilities + +makeExtendingDatatype "DocumentFormattingOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''DocumentFormattingOptions + +makeExtendingDatatype "DocumentFormattingRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''DocumentFormattingOptions + ] + [] +deriveJSON lspOptions ''DocumentFormattingRegistrationOptions +-- | Value-object describing what options formatting should use. data FormattingOptions = FormattingOptions - { _tabSize :: Int - , _insertSpaces :: Bool -- ^ Prefer spaces over tabs + { _tabSize :: Int -- ^ Size of a tab in spaces. + , _insertSpaces :: Bool -- ^ Prefer spaces over tabs + , _trimTrailingWhitespace :: Maybe Bool -- ^ Trim trailing whitespace on a line. Since LSP 3.15.0 + , _insertFinalNewline :: Maybe Bool -- ^ Insert a newline character at the end of the file if one does not exist. Since LSP 3.15.0 + , _trimFinalNewlines :: Maybe Bool -- ^ Trim all newlines after the final newline at the end of the file. Since LSP 3.15.0 -- Note: May be more properties } deriving (Read,Show,Eq) - deriveJSON lspOptions ''FormattingOptions -data DocumentFormattingParams = - DocumentFormattingParams - { _textDocument :: TextDocumentIdentifier - , _options :: FormattingOptions - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Show,Read,Eq) - -deriveJSON lspOptions ''DocumentFormattingParams - -data DocumentFormattingOptions = - DocumentFormattingOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentFormattingOptions ["_workDoneProgressOptions"] - -data DocumentFormattingRegistrationOptions = - DocumentFormattingRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _documentFormattingOptions :: DocumentFormattingOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentFormattingRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_documentFormattingOptions" +makeExtendingDatatype "DocumentFormattingParams" [''WorkDoneProgressParams] + [ ("_textDocument", [t| TextDocumentIdentifier |]) + , ("_options", [t| FormattingOptions |]) ] +deriveJSON lspOptions ''DocumentFormattingParams --- --------------------------------------------------------------------- -{- -Document Range Formatting Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-range-formatting-request - -The document range formatting request is sent from the client to the server to -format a given range in a document. - -Request - - method: 'textDocument/rangeFormatting', - params: DocumentRangeFormattingParams defined as follows - -interface DocumentRangeFormattingParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The range to format - */ - range: Range; - - /** - * The format options - */ - options: FormattingOptions; -} - -Response - - result: TextEdit[] describing the modification to the document to be - formatted. - error: code and message set in case an exception happens during the range - formatting request. --} - -data DocumentRangeFormattingParams = - DocumentRangeFormattingParams - { _textDocument :: TextDocumentIdentifier - , _range :: Range - , _options :: FormattingOptions - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Read,Show,Eq) +-- ------------------------------------- -deriveJSON lspOptions ''DocumentRangeFormattingParams +data DocumentRangeFormattingClientCapabilities = + DocumentRangeFormattingClientCapabilities + { -- | Whether formatting supports dynamic registration. + _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''DocumentRangeFormattingClientCapabilities -data DocumentRangeFormattingOptions = - DocumentRangeFormattingOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentRangeFormattingOptions ["_workDoneProgressOptions"] +makeExtendingDatatype "DocumentRangeFormattingOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''DocumentRangeFormattingOptions -data DocumentRangeFormattingRegistrationOptions = - DocumentRangeFormattingRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _documentRangeFormattingOptions :: DocumentRangeFormattingOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentRangeFormattingRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_documentRangeFormattingOptions" +makeExtendingDatatype "DocumentRangeFormattingRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''DocumentRangeFormattingOptions ] + [] +deriveJSON lspOptions ''DocumentRangeFormattingRegistrationOptions --- --------------------------------------------------------------------- -{- -Document on Type Formatting Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-on-type-formatting-request - -The document on type formatting request is sent from the client to the server to -format parts of the document during typing. - -Request - - method: 'textDocument/onTypeFormatting' - params: DocumentOnTypeFormattingParams defined as follows - -interface DocumentOnTypeFormattingParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The position at which this request was sent. - */ - position: Position; - - /** - * The character that has been typed. - */ - ch: string; - - /** - * The format options. - */ - options: FormattingOptions; -} - -Response - - result: TextEdit[] describing the modification to the document. - error: code and message set in case an exception happens during the range - formatting request. - -Registration Options: DocumentOnTypeFormattingRegistrationOptions defined as follows: - -export interface DocumentOnTypeFormattingRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * A character on which formatting should be triggered, like `}`. - */ - firstTriggerCharacter: string; - /** - * More trigger characters. - */ - moreTriggerCharacter?: string[] -} --} - -data DocumentOnTypeFormattingParams = - DocumentOnTypeFormattingParams - { _textDocument :: TextDocumentIdentifier - , _position :: Position - , _ch :: Text - , _options :: FormattingOptions - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DocumentOnTypeFormattingParams +makeExtendingDatatype "DocumentRangeFormattingParams" [''WorkDoneProgressParams] + [ ("_textDocument", [t| TextDocumentIdentifier |]) + , ("_range", [t| Range |]) + , ("_options", [t| FormattingOptions |]) + ] +deriveJSON lspOptions ''DocumentRangeFormattingParams +-- ------------------------------------- --- --------------------------------------------------------------------- -{- -/** - * Format document on type options - */ -interface DocumentOnTypeFormattingOptions { - /** - * A character on which formatting should be triggered, like `}`. - */ - firstTriggerCharacter: string; - /** - * More trigger characters. - */ - moreTriggerCharacter?: string[] -} --} +data DocumentOnTypeFormattingClientCapabilities = + DocumentOnTypeFormattingClientCapabilities + { -- | Whether formatting supports dynamic registration. + _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''DocumentOnTypeFormattingClientCapabilities data DocumentOnTypeFormattingOptions = DocumentOnTypeFormattingOptions @@ -254,17 +86,17 @@ data DocumentOnTypeFormattingOptions = , -- | More trigger characters. _moreTriggerCharacter :: Maybe [Text] } deriving (Read,Show,Eq) - deriveJSON lspOptions ''DocumentOnTypeFormattingOptions -data DocumentOnTypeFormattingRegistrationOptions = - DocumentOnTypeFormattingRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - -- This doesn't extend WorkDoneProgressOptions -- is this an oversight in the spec? - -- https://github.com/microsoft/language-server-protocol/issues/987 - , _documentOnTypeFormattingOptions :: DocumentOnTypeFormattingOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''DocumentOnTypeFormattingRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_documentOnTypeFormattingOptions" +makeExtendingDatatype "DocumentOnTypeFormattingRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''DocumentOnTypeFormattingOptions ] + [] +deriveJSON lspOptions ''DocumentOnTypeFormattingRegistrationOptions + +makeExtendingDatatype "DocumentOnTypeFormattingParams" [''TextDocumentPositionParams] + [ ("_ch", [t| String |]) + , ("_options", [t| FormattingOptions |]) + ] +deriveJSON lspOptions ''DocumentOnTypeFormattingParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index fe9a08825..5240bdbbf 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -60,9 +60,6 @@ makeFieldsNoPrefix ''SignatureHelpSignatureInformation makeFieldsNoPrefix ''SignatureHelpParameterInformation makeFieldsNoPrefix ''SignatureHelpClientCapabilities makeFieldsNoPrefix ''ReferencesClientCapabilities -makeFieldsNoPrefix ''FormattingClientCapabilities -makeFieldsNoPrefix ''RangeFormattingClientCapabilities -makeFieldsNoPrefix ''OnTypeFormattingClientCapabilities makeFieldsNoPrefix ''DefinitionClientCapabilities makeFieldsNoPrefix ''TypeDefinitionClientCapabilities makeFieldsNoPrefix ''ImplementationClientCapabilities @@ -79,7 +76,6 @@ makeFieldsNoPrefix ''InitializeParams makeFieldsNoPrefix ''InitializeError makeFieldsNoPrefix ''CompletionOptions makeFieldsNoPrefix ''SignatureHelpOptions -makeFieldsNoPrefix ''DocumentOnTypeFormattingOptions makeFieldsNoPrefix ''ExecuteCommandOptions makeFieldsNoPrefix ''SaveOptions makeFieldsNoPrefix ''TextDocumentSyncOptions @@ -117,10 +113,6 @@ makeFieldsNoPrefix ''SignatureHelpRegistrationOptions makeFieldsNoPrefix ''ReferenceContext makeFieldsNoPrefix ''ReferenceParams makeFieldsNoPrefix ''WorkspaceSymbolParams -makeFieldsNoPrefix ''FormattingOptions -makeFieldsNoPrefix ''DocumentFormattingParams -makeFieldsNoPrefix ''DocumentRangeFormattingParams -makeFieldsNoPrefix ''DocumentOnTypeFormattingParams makeFieldsNoPrefix ''RenameParams makeFieldsNoPrefix ''ExecuteCommandParams makeFieldsNoPrefix ''ExecuteCommandRegistrationOptions @@ -179,6 +171,25 @@ makeFieldsNoPrefix ''ColorInformation makeFieldsNoPrefix ''ColorPresentationParams makeFieldsNoPrefix ''ColorPresentation +-- Formatting +makeFieldsNoPrefix ''DocumentFormattingClientCapabilities +makeFieldsNoPrefix ''DocumentFormattingOptions +makeFieldsNoPrefix ''DocumentFormattingRegistrationOptions +makeFieldsNoPrefix ''FormattingOptions +makeFieldsNoPrefix ''DocumentFormattingParams + +-- RangeFormatting +makeFieldsNoPrefix ''DocumentRangeFormattingClientCapabilities +makeFieldsNoPrefix ''DocumentRangeFormattingOptions +makeFieldsNoPrefix ''DocumentRangeFormattingRegistrationOptions +makeFieldsNoPrefix ''DocumentRangeFormattingParams + +-- OnTypeFormatting +makeFieldsNoPrefix ''DocumentOnTypeFormattingClientCapabilities +makeFieldsNoPrefix ''DocumentOnTypeFormattingOptions +makeFieldsNoPrefix ''DocumentOnTypeFormattingRegistrationOptions +makeFieldsNoPrefix ''DocumentOnTypeFormattingParams + -- DocumentHighlight makeFieldsNoPrefix ''DocumentHighlightClientCapabilities makeFieldsNoPrefix ''DocumentHighlightOptions From 11517f15d361499512eff63e8238f06f5fbc2205 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 16:25:55 +0100 Subject: [PATCH 20/63] Update rename and prepareRename --- .../Haskell/LSP/Types/ClientCapabilities.hs | 13 +- .../Language/Haskell/LSP/Types/Formatting.hs | 33 +++-- .../src/Language/Haskell/LSP/Types/Lens.hs | 13 +- .../src/Language/Haskell/LSP/Types/Rename.hs | 139 ++++-------------- 4 files changed, 62 insertions(+), 136 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index efe3048cf..ec1cd1cef 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -19,8 +19,9 @@ import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation -import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils @@ -660,16 +661,6 @@ deriveJSON lspOptions ''ColorProviderClientCapabilities -- ------------------------------------- -data RenameClientCapabilities = - RenameClientCapabilities - { _dynamicRegistration :: Maybe Bool - , _prepareSupport :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''RenameClientCapabilities - --- ------------------------------------- - data PublishDiagnosticsTagsClientCapabilities = PublishDiagnosticsTagsClientCapabilities { -- | The tags supported by the client. diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs index 0e19cf190..284de0c0d 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Formatting.hs @@ -20,24 +20,35 @@ makeExtendingDatatype "DocumentFormattingOptions" [''WorkDoneProgressOptions] [] deriveJSON lspOptions ''DocumentFormattingOptions makeExtendingDatatype "DocumentFormattingRegistrationOptions" - [ ''TextDocumentRegistrationOptions - , ''DocumentFormattingOptions + [ ''TextDocumentRegistrationOptions, + ''DocumentFormattingOptions ] [] deriveJSON lspOptions ''DocumentFormattingRegistrationOptions -- | Value-object describing what options formatting should use. -data FormattingOptions = - FormattingOptions - { _tabSize :: Int -- ^ Size of a tab in spaces. - , _insertSpaces :: Bool -- ^ Prefer spaces over tabs - , _trimTrailingWhitespace :: Maybe Bool -- ^ Trim trailing whitespace on a line. Since LSP 3.15.0 - , _insertFinalNewline :: Maybe Bool -- ^ Insert a newline character at the end of the file if one does not exist. Since LSP 3.15.0 - , _trimFinalNewlines :: Maybe Bool -- ^ Trim all newlines after the final newline at the end of the file. Since LSP 3.15.0 +data FormattingOptions = FormattingOptions + { -- | Size of a tab in spaces. + _tabSize :: Int, + -- | Prefer spaces over tabs + _insertSpaces :: Bool, + -- | Trim trailing whitespace on a line. + -- + -- Since LSP 3.15.0 + _trimTrailingWhitespace :: Maybe Bool, + -- | Insert a newline character at the end of the file if one does not exist. + -- + -- Since LSP 3.15.0 + _insertFinalNewline :: Maybe Bool, + -- | Trim all newlines after the final newline at the end of the file. + -- + -- Since LSP 3.15.0 + _trimFinalNewlines :: Maybe Bool -- Note: May be more properties - } deriving (Read,Show,Eq) -deriveJSON lspOptions ''FormattingOptions + } + deriving (Read, Show, Eq) +deriveJSON lspOptions ''FormattingOptions makeExtendingDatatype "DocumentFormattingParams" [''WorkDoneProgressParams] [ ("_textDocument", [t| TextDocumentIdentifier |]) , ("_options", [t| FormattingOptions |]) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 5240bdbbf..f8bdbb9ed 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -64,7 +64,6 @@ makeFieldsNoPrefix ''DefinitionClientCapabilities makeFieldsNoPrefix ''TypeDefinitionClientCapabilities makeFieldsNoPrefix ''ImplementationClientCapabilities makeFieldsNoPrefix ''ColorProviderClientCapabilities -makeFieldsNoPrefix ''RenameClientCapabilities makeFieldsNoPrefix ''PublishDiagnosticsClientCapabilities makeFieldsNoPrefix ''PublishDiagnosticsTagsClientCapabilities makeFieldsNoPrefix ''TextDocumentClientCapabilities @@ -113,7 +112,6 @@ makeFieldsNoPrefix ''SignatureHelpRegistrationOptions makeFieldsNoPrefix ''ReferenceContext makeFieldsNoPrefix ''ReferenceParams makeFieldsNoPrefix ''WorkspaceSymbolParams -makeFieldsNoPrefix ''RenameParams makeFieldsNoPrefix ''ExecuteCommandParams makeFieldsNoPrefix ''ExecuteCommandRegistrationOptions makeFieldsNoPrefix ''ApplyWorkspaceEditParams @@ -190,6 +188,17 @@ makeFieldsNoPrefix ''DocumentOnTypeFormattingOptions makeFieldsNoPrefix ''DocumentOnTypeFormattingRegistrationOptions makeFieldsNoPrefix ''DocumentOnTypeFormattingParams +-- Rename +makeFieldsNoPrefix ''RenameClientCapabilities +makeFieldsNoPrefix ''RenameOptions +makeFieldsNoPrefix ''RenameRegistrationOptions +makeFieldsNoPrefix ''RenameParams + +-- PrepareRename +makeFieldsNoPrefix ''PrepareRenameParams +makeFieldsNoPrefix ''RangeWithPlaceholder + + -- DocumentHighlight makeFieldsNoPrefix ''DocumentHighlightClientCapabilities makeFieldsNoPrefix ''DocumentHighlightOptions diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs index 039f80c32..0ac54a428 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs @@ -11,88 +11,40 @@ import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Utils --- --------------------------------------------------------------------- -{- -Rename Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#rename-request - -The rename request is sent from the client to the server to perform a -workspace-wide rename of a symbol. - -Request - - method: 'textDocument/rename' - params: RenameParams defined as follows - -interface RenameParams { - /** - * The document to format. - */ - textDocument: TextDocumentIdentifier; - - /** - * The position at which this request was sent. - */ - position: Position; - - /** - * The new name of the symbol. If the given name is not valid the - * request must return a [ResponseError](#ResponseError) with an - * appropriate message set. - */ - newName: string; -} - -Response - - result: WorkspaceEdit describing the modification to the workspace. - error: code and message set in case an exception happens during the rename - request. - -Registration Options: TextDocumentRegistrationOptions - --} -data RenameParams = - RenameParams - { _textDocument :: TextDocumentIdentifier - , _position :: Position - , _newName :: Text - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. +data RenameClientCapabilities = + RenameClientCapabilities + { -- | Whether rename supports dynamic registration. + _dynamicRegistration :: Maybe Bool + -- | Client supports testing for validity of rename operations + -- before execution. + -- + -- Since LSP 3.12.0 + , _prepareSupport :: Maybe Bool } deriving (Show, Read, Eq) -deriveJSON lspOptions ''RenameParams - - --- {\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"textDocument/rename\",\"params\":{\"textDocument\":{\"uri\":\"file:///home/alanz/mysrc/github/alanz/haskell-lsp/src/HieVscode.hs\"},\"position\":{\"line\":37,\"character\":17},\"newName\":\"getArgs'\"}} - --- --------------------------------------------------------------------- -{- -Prepare Rename Request +deriveJSON lspOptions ''RenameClientCapabilities -Since version 3.12.0 +makeExtendingDatatype "RenameOptions" [''WorkDoneProgressOptions] + [("_prepareProvider", [t| Maybe Bool |])] +deriveJSON lspOptions ''RenameOptions -The prepare rename request is sent from the client to the server to setup -and test the validity of a rename operation at a given location. +makeExtendingDatatype "RenameRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''RenameOptions + ] [] +deriveJSON lspOptions ''RenameRegistrationOptions -Request: - - method: ‘textDocument/prepareRename’ - params: TextDocumentPositionParams - -Response: - - result: Range | { range: Range, placeholder: string } | null describing - the range of the string to rename and optionally a placeholder - text of the string content to be renamed. If null is returned - then it is deemed that a ‘textDocument/rename’ request is not - valid at the given position. - error: code and message set in case an exception happens during the - prepare rename request. +makeExtendingDatatype "RenameParams" + [ ''TextDocumentRegistrationOptions + , ''RenameOptions + ] + [("_newName", [t| String |])] +deriveJSON lspOptions ''RenameParams --} +-- ----------------------------------------- --- {\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"textDocument/rename\",\"params\":{\"textDocument\":{\"uri\":\"file:///home/alanz/mysrc/github/alanz/haskell-lsp/src/HieVscode.hs\"},\"position\":{\"line\":37,\"character\":17},\"newName\":\"getArgs'\"}} +makeExtendingDatatype "PrepareRenameParams" [''TextDocumentPositionParams] [] +deriveJSON lspOptions ''PrepareRenameParams data RangeWithPlaceholder = RangeWithPlaceholder @@ -108,40 +60,3 @@ data RangeOrRangeWithPlaceholder = RangeWithPlaceholderValue RangeWithPlaceholde deriving Eq deriveJSON lspOptions { sumEncoding = UntaggedValue } ''RangeOrRangeWithPlaceholder - - --- --------------------------------------------------------------------- -{- -New in 3.12 ----------- - -/** - * Rename options - */ -export interface RenameOptions { - /** - * Renames should be checked and tested before being executed. - */ - prepareProvider?: boolean; -} --} - -data RenameOptions = - RenameOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - -- | Renames should be checked and tested before being executed. - , _prepareProvider :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSONExtendFields lspOptions ''RenameOptions ["_workDoneProgressOptions"] - -data RenameRegistrationOptions = - RenameRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _renameOptions :: RenameOptions - } deriving (Read,Show,Eq) - -deriveJSONExtendFields lspOptions ''RenameRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_renameOptions" - ] From 859ccbec3f6def04530a9ea560b8bbf669b3600a Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 13 Aug 2020 16:54:36 +0100 Subject: [PATCH 21/63] Update foldingRange, add selectionRange --- haskell-lsp-types/haskell-lsp-types.cabal | 3 +- .../src/Language/Haskell/LSP/Types.hs | 2 + .../Haskell/LSP/Types/ClientCapabilities.hs | 21 +--- .../Haskell/LSP/Types/DataTypesJSON.hs | 24 ++-- .../Haskell/LSP/Types/FoldingRange.hs | 61 ++++++---- .../src/Language/Haskell/LSP/Types/Lens.hs | 17 ++- .../src/Language/Haskell/LSP/Types/Message.hs | 12 +- .../src/Language/Haskell/LSP/Types/Method.hs | 4 + .../src/Language/Haskell/LSP/Types/Rename.hs | 17 +-- .../Haskell/LSP/Types/SelectionRange.hs | 54 +++++++++ .../src/Language/Haskell/LSP/Types/Utils.hs | 104 ++---------------- 11 files changed, 146 insertions(+), 173 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/SelectionRange.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index e77fa33ac..0bd4cfe97 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -35,6 +35,7 @@ library , Language.Haskell.LSP.Types.DocumentFilter , Language.Haskell.LSP.Types.DocumentHighlight , Language.Haskell.LSP.Types.DocumentLink + , Language.Haskell.LSP.Types.DocumentSymbol , Language.Haskell.LSP.Types.FoldingRange , Language.Haskell.LSP.Types.Formatting , Language.Haskell.LSP.Types.Hover @@ -48,10 +49,10 @@ library , Language.Haskell.LSP.Types.Registration , Language.Haskell.LSP.Types.References , Language.Haskell.LSP.Types.Rename + , Language.Haskell.LSP.Types.SelectionRange , Language.Haskell.LSP.Types.ServerCapabilities , Language.Haskell.LSP.Types.SignatureHelp , Language.Haskell.LSP.Types.StaticRegistrationOptions - , Language.Haskell.LSP.Types.DocumentSymbol , Language.Haskell.LSP.Types.Synonyms , Language.Haskell.LSP.Types.TextDocument , Language.Haskell.LSP.Types.TypeDefinition diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 070c0ca20..18f938498 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -27,6 +27,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.SignatureHelp , module Language.Haskell.LSP.Types.StaticRegistrationOptions , module Language.Haskell.LSP.Types.DocumentSymbol + , module Language.Haskell.LSP.Types.SelectionRange , module Language.Haskell.LSP.Types.Synonyms , module Language.Haskell.LSP.Types.TextDocument , module Language.Haskell.LSP.Types.TypeDefinition @@ -62,6 +63,7 @@ import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.DocumentSymbol diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index ec1cd1cef..89a5b6989 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -16,6 +16,7 @@ import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.DocumentSymbol +import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation @@ -684,26 +685,6 @@ deriveJSON lspOptions ''PublishDiagnosticsClientCapabilities -- ------------------------------------- -data FoldingRangeClientCapabilities = - FoldingRangeClientCapabilities - { -- | Whether implementation supports dynamic registration for folding range - -- providers. If this is set to `true` the client supports the new - -- `(FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions)` - -- return value for the corresponding server capability as well. - _dynamicRegistration :: Maybe Bool - -- | The maximum number of folding ranges that the client prefers to receive - -- per document. The value serves as a hint, servers are free to follow the limit. - , _rangeLimit :: Maybe Int - -- | If set, the client signals that it only supports folding complete lines. If set, - -- client will ignore specified `startCharacter` and `endCharacter` properties in a - -- FoldingRange. - , _lineFoldingOnly :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''FoldingRangeClientCapabilities - --- ------------------------------------- - data TextDocumentClientCapabilities = TextDocumentClientCapabilities { _synchronization :: Maybe SynchronizationTextDocumentClientCapabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index 2c19e1028..f6e93c8a4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -652,15 +652,11 @@ export interface TextDocumentChangeRegistrationOptions extends TextDocumentRegis } -} -data TextDocumentChangeRegistrationOptions = - TextDocumentChangeRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - -- | How documents are synced to the server. - -- See 'TdSyncFull' and 'TdSyncIncremental' - , _syncKind :: TextDocumentSyncKind - } deriving (Show, Read, Eq) +makeExtendingDatatype "TextDocumentChangeRegistrationOptions" + [''TextDocumentRegistrationOptions] + [("_syncKind", [t| TextDocumentSyncKind |])] -deriveJSONExtendFields lspOptions ''TextDocumentChangeRegistrationOptions ["_textDocumentRegistrationOptions"] +deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions -- --------------------------------------------------------------------- {- @@ -828,15 +824,11 @@ data DidSaveTextDocumentParams = deriveJSON lspOptions ''DidSaveTextDocumentParams -data TextDocumentSaveRegistrationOptions = - TextDocumentSaveRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - -- The spec doesn't say it extends SaveOptions, but it's the same fields. - -- Looks like an oversight - , _saveOptions :: SaveOptions - } deriving (Show, Read, Eq) +makeExtendingDatatype "TextDocumentSaveRegistrationOptions" + [''TextDocumentRegistrationOptions] + [("_saveOptions", [t| SaveOptions |])] -deriveJSONExtendFields lspOptions ''TextDocumentSaveRegistrationOptions ["_textDocumentRegistrationOptions", "_saveOptions"] +deriveJSON lspOptions ''TextDocumentSaveRegistrationOptions -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs index d69c4efc2..0019dae61 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/FoldingRange.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.LSP.Types.FoldingRange where @@ -10,13 +11,43 @@ import Language.Haskell.LSP.Types.StaticRegistrationOptions import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Utils -data FoldingRangeParams = - FoldingRangeParams - { _textDocument :: TextDocumentIdentifier -- ^ The text document. - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } - deriving (Read, Show, Eq) +-- ------------------------------------- + +data FoldingRangeClientCapabilities = + FoldingRangeClientCapabilities + { -- | Whether implementation supports dynamic registration for folding range + -- providers. If this is set to `true` the client supports the new + -- `(FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions)` + -- return value for the corresponding server capability as well. + _dynamicRegistration :: Maybe Bool + -- | The maximum number of folding ranges that the client prefers to receive + -- per document. The value serves as a hint, servers are free to follow the limit. + , _rangeLimit :: Maybe Int + -- | If set, the client signals that it only supports folding complete lines. If set, + -- client will ignore specified `startCharacter` and `endCharacter` properties in a + -- FoldingRange. + , _lineFoldingOnly :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''FoldingRangeClientCapabilities + +makeExtendingDatatype "FoldingRangeOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''FoldingRangeOptions + +makeExtendingDatatype "FoldingRangeRegistrationOptions" + [ ''TextDocumentRegistrationOptions + , ''FoldingRangeOptions + , ''StaticRegistrationOptions + ] [] +deriveJSON lspOptions ''FoldingRangeRegistrationOptions + + +makeExtendingDatatype "FoldingRangeParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [("_textDocument", [t| TextDocumentIdentifier |])] deriveJSON lspOptions ''FoldingRangeParams -- | Enum of known range kinds @@ -66,21 +97,3 @@ data FoldingRange = deriving (Read, Show, Eq) deriveJSON lspOptions ''FoldingRange - -data FoldingRangeOptions = - FoldingRangeOptions - { _workDoneProgressOptions :: WorkDoneProgressOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''FoldingRangeOptions ["_workDoneProgressOptions"] - -data FoldingRangeRegistrationOptions = - FoldingRangeRegistrationOptions - { _textDocumentRegistrationOptions :: TextDocumentRegistrationOptions - , _foldingRangeOptions :: FoldingRangeOptions - , _staticRegistrationOptions :: StaticRegistrationOptions - } deriving (Read,Show,Eq) -deriveJSONExtendFields lspOptions ''FoldingRangeRegistrationOptions - [ "_textDocumentRegistrationOptions" - , "_foldingRangeOptions" - , "_staticRegistrationOptions" - ] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index f8bdbb9ed..b45d979bf 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -30,6 +30,7 @@ import Language.Haskell.LSP.Types.Registration import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp +import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.TextDocument @@ -198,6 +199,19 @@ makeFieldsNoPrefix ''RenameParams makeFieldsNoPrefix ''PrepareRenameParams makeFieldsNoPrefix ''RangeWithPlaceholder +-- FoldingRange +makeFieldsNoPrefix ''FoldingRangeClientCapabilities +makeFieldsNoPrefix ''FoldingRangeOptions +makeFieldsNoPrefix ''FoldingRangeRegistrationOptions +makeFieldsNoPrefix ''FoldingRangeParams +makeFieldsNoPrefix ''FoldingRange + +-- SelectionRange +makeFieldsNoPrefix ''SelectionRangeClientCapabilities +makeFieldsNoPrefix ''SelectionRangeOptions +makeFieldsNoPrefix ''SelectionRangeRegistrationOptions +makeFieldsNoPrefix ''SelectionRangeParams +makeFieldsNoPrefix ''SelectionRange -- DocumentHighlight makeFieldsNoPrefix ''DocumentHighlightClientCapabilities @@ -252,9 +266,6 @@ makeFieldsNoPrefix ''DiagnosticRelatedInformation makeFieldsNoPrefix ''Hover makeFieldsNoPrefix ''HoverRegistrationOptions --- Folding Range -makeFieldsNoPrefix ''FoldingRange -makeFieldsNoPrefix ''FoldingRangeParams -- Window makeFieldsNoPrefix ''ShowMessageParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index da086132a..18c59a6c5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -40,9 +40,9 @@ import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Registration import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.DocumentSymbol -import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.Window @@ -114,9 +114,11 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams TextDocumentOnTypeFormatting = DocumentOnTypeFormattingParams -- Rename MessageParams TextDocumentRename = RenameParams - MessageParams TextDocumentPrepareRename = TextDocumentPositionParams - -- FoldingRange + MessageParams TextDocumentPrepareRename = PrepareRenameParams + -- Folding Range MessageParams TextDocumentFoldingRange = FoldingRangeParams + -- Selection Range + MessageParams TextDocumentSelectionRange = SelectionRangeParams -- Server -- Window MessageParams WindowShowMessage = ShowMessageParams @@ -183,9 +185,10 @@ type family ResponseParams (m :: Method p Request) :: Type where ResponseParams TextDocumentOnTypeFormatting = List TextEdit -- Rename ResponseParams TextDocumentRename = WorkspaceEdit - ResponseParams TextDocumentPrepareRename = Maybe RangeOrRangeWithPlaceholder + ResponseParams TextDocumentPrepareRename = Range |? RangeWithPlaceholder -- FoldingRange ResponseParams TextDocumentFoldingRange = List FoldingRange + ResponseParams TextDocumentSelectionRange = List SelectionRange -- Custom can be either a notification or a message -- Server -- Window @@ -665,6 +668,7 @@ splitClientMethod STextDocumentOnTypeFormatting = IsClientReq splitClientMethod STextDocumentRename = IsClientReq splitClientMethod STextDocumentPrepareRename = IsClientReq splitClientMethod STextDocumentFoldingRange = IsClientReq +splitClientMethod STextDocumentSelectionRange = IsClientReq splitClientMethod SCancelRequest = IsClientNot splitClientMethod SCustomMethod{} = IsClientEither diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index 86190688e..d7639ee5d 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -75,6 +75,7 @@ data Method (p :: Provenance) (t :: MethodType) where TextDocumentPrepareRename :: Method FromClient Request -- FoldingRange TextDocumentFoldingRange :: Method FromClient Request + TextDocumentSelectionRange :: Method FromClient Request -- ServerMethods -- Window @@ -142,6 +143,7 @@ data SMethod (m :: Method p t) where STextDocumentRename :: SMethod TextDocumentRename STextDocumentPrepareRename :: SMethod TextDocumentPrepareRename STextDocumentFoldingRange :: SMethod TextDocumentFoldingRange + STextDocumentSelectionRange :: SMethod TextDocumentSelectionRange SWindowShowMessage :: SMethod WindowShowMessage SWindowShowMessageRequest :: SMethod WindowShowMessageRequest @@ -260,6 +262,7 @@ instance FromJSON SomeClientMethod where parseJSON (A.String "textDocument/rename") = pure $ SomeClientMethod STextDocumentRename parseJSON (A.String "textDocument/prepareRename") = pure $ SomeClientMethod STextDocumentPrepareRename parseJSON (A.String "textDocument/foldingRange") = pure $ SomeClientMethod STextDocumentFoldingRange + parseJSON (A.String "textDocument/selectionRange") = pure $ SomeClientMethod STextDocumentFoldingRange parseJSON (A.String "window/workDoneProgress/cancel") = pure $ SomeClientMethod SWorkDoneProgressCancel -- Cancelling parseJSON (A.String "$/cancelRequest") = pure $ SomeClientMethod SCancelRequest @@ -350,6 +353,7 @@ instance A.ToJSON (SMethod m) where toJSON STextDocumentRename = A.String "textDocument/rename" toJSON STextDocumentPrepareRename = A.String "textDocument/prepareRename" toJSON STextDocumentFoldingRange = A.String "textDocument/foldingRange" + toJSON STextDocumentSelectionRange = A.String "textDocument/selectionRange" toJSON STextDocumentDocumentLink = A.String "textDocument/documentLink" toJSON SDocumentLinkResolve = A.String "documentLink/resolve" toJSON SWorkDoneProgressCancel = A.String "window/workDoneProgress/cancel" diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs index 0ac54a428..8f297a172 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs @@ -48,15 +48,8 @@ deriveJSON lspOptions ''PrepareRenameParams data RangeWithPlaceholder = RangeWithPlaceholder - { - _range :: Range - , _placeholder :: Text - } deriving Eq - -deriveJSON lspOptions { sumEncoding = UntaggedValue } ''RangeWithPlaceholder - -data RangeOrRangeWithPlaceholder = RangeWithPlaceholderValue RangeWithPlaceholder - | RangeValue Range - deriving Eq - -deriveJSON lspOptions { sumEncoding = UntaggedValue } ''RangeOrRangeWithPlaceholder + { + _range :: Range + , _placeholder :: Text + } deriving Eq +deriveJSON lspOptions ''RangeWithPlaceholder diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/SelectionRange.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/SelectionRange.hs new file mode 100644 index 000000000..07ab78e6b --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/SelectionRange.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.LSP.Types.SelectionRange where + +import Data.Aeson.TH +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.StaticRegistrationOptions +import Language.Haskell.LSP.Types.TextDocument +import Language.Haskell.LSP.Types.Utils + +data SelectionRangeClientCapabilities = SelectionRangeClientCapabilities + { -- | Whether implementation supports dynamic registration for selection range providers. If this is set to 'True' + -- the client supports the new 'SelectionRangeRegistrationOptions' return value for the corresponding server + -- capability as well. + _dynamicRegistration :: Maybe Bool + } + deriving (Read, Show, Eq) + +deriveJSON lspOptions ''SelectionRangeClientCapabilities + +makeExtendingDatatype "SelectionRangeOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''SelectionRangeOptions + +makeExtendingDatatype + "SelectionRangeRegistrationOptions" + [ ''SelectionRangeOptions, + ''TextDocumentRegistrationOptions, + ''StaticRegistrationOptions + ] + [] +deriveJSON lspOptions ''SelectionRangeRegistrationOptions + +makeExtendingDatatype + "SelectionRangeParams" + [ ''WorkDoneProgressParams, + ''PartialResultParams + ] + [ ("_textDocument", [t|TextDocumentIdentifier|]), + ("_positions", [t|List Position|]) + ] +deriveJSON lspOptions ''SelectionRangeParams + +data SelectionRange = SelectionRange + { -- | The 'range' of this selection range. + _range :: Range, + -- | The parent selection range containing this range. Therefore @parent.range@ must contain @this.range@. + _parent :: Maybe SelectionRange + } + deriving (Read, Show, Eq) + +deriveJSON lspOptions ''SelectionRange diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs index 204076b18..138c0e1be 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs @@ -5,18 +5,15 @@ module Language.Haskell.LSP.Types.Utils ( rdrop , makeSingletonFromJSON - , deriveJSONExtendFields , makeRegHelper , makeExtendingDatatype , lspOptions ) where -import Language.Haskell.TH -import Data.Aeson -import qualified Data.HashMap.Strict as HM -import Data.String import Control.Monad -import Data.List (foldl', (\\)) +import Data.Aeson +import Data.List +import Language.Haskell.TH -- --------------------------------------------------------------------- @@ -50,92 +47,6 @@ makeInst wrap (GadtC [sConstructor] args t) = do makeInst wrap (ForallC _ _ con) = makeInst wrap con -- Cancel and Custom requests makeInst _ _ = fail "makeInst only defined for GADT constructors" --- | Generate ToJSON/FromJSON instances where the specified fields are --- encoded directly inside object, unwrapped, and not another layer. --- Use this for encoding types that extend an interface in the typescript --- specification. --- The field names are passed as strings to work around duplicate record fields. -deriveJSONExtendFields :: Options -> Name -> [String] -> Q [Dec] -deriveJSONExtendFields opts name fieldStringsToExtend = do - TyConI datad <- reify name - let DataD _ _ _ _ [con] _ = datad - RecC conName varbangtyps = con - fields = map (\(n,_,_) -> n) varbangtyps - conType = ConT name - - fieldNames = map (\(n,_,_) -> n) varbangtyps - lookupFields s = - case filter ((== s) . nameBase) fieldNames of - [n] -> pure n - _ -> fail $ "Couldn't find field to extend: " <> s - - -- Need to convert from strings of fields -> names of fields - fieldsToExtend <- mapM lookupFields fieldStringsToExtend - - to <- deriveToJSONExtendFields opts (pure conType) fields fieldsToExtend - from <- deriveFromJSONExtendFields opts conType conName fields fieldsToExtend - return (to ++ from) - -{- --- Note: in extends, we need to put the x there to disambiguate in the presence of - duplicate record fields - -instance ToJSON Foo where - toJSON x = Object (mconcat (mainObj:extendMaps)) - where extends = map [toJSON (_baz (x :: Foo))] - unwrapObj (Object hm) = hm - extendMaps = map unwrapObj extends - mainObj = HM.fromList [("_foo", toJSON (_foo (x :: Foo)))] --} -deriveToJSONExtendFields :: Options -> TypeQ -> [Name] -> [Name] -> Q [Dec] -deriveToJSONExtendFields opts typ fields fieldsToExtend = do - xName <- newName "x" - let mkToJSON :: Name -> ExpQ - mkToJSON n = [e| toJSON ($(varE n) ($(varE xName) :: $typ))|] - mkHMTuple fieldName = - [e| (fromString $(stringE (fieldLabelModifier opts (nameBase fieldName))) - , toJSON ($(varE fieldName) ($(varE xName) :: $typ ))) |] - - [d| instance ToJSON $typ where - toJSON $(varP xName) = Object (mconcat (mainObj:extendMaps)) - where extends = $(listE (mkToJSON <$> fieldsToExtend)) - unwrapObj (Object hm) = hm - extendMaps = map unwrapObj extends - mainObj = HM.fromList - $(listE (mkHMTuple <$> (fields \\ fieldsToExtend))) - |] - where - -{- -instance FromJSON Foo where - parseJSON o@(Object v) = - Foo <$> parseJSON o <*> v .: "foo" - parseJSON _ = mempty --} -deriveFromJSONExtendFields :: Options -> Type -> Name -> [Name] -> [Name] -> Q [Dec] -deriveFromJSONExtendFields opts typ tyConName fields fieldsToExtend = do - oName <- newName "_o" -- the object name - vName <- newName "_v" -- the value name - ConE objectName <- [e| Object |] - - let fieldExprs = map mkParseExp fields - pat = asP oName (conP objectName [varP vName]) - apArgs :: [ExpQ] -> ExpQ - apArgs [] = error "No arguments!" - apArgs [e] = e - apArgs [e,e'] = [e| $e <$> $e' |] - apArgs es = [e| $(apArgs (init es)) <*> $(last es) |] - - mkParseExp fieldName - | fieldName `elem` fieldsToExtend = [e| parseJSON $(varE oName) |] - | otherwise = - [e| $(varE vName) .: fromString $(stringE (fieldLabelModifier opts (nameBase fieldName))) |] - - [d| instance FromJSON $(pure typ) where - parseJSON $pat = $(apArgs ((conE tyConName):fieldExprs)) - parseJSON _ = mempty - |] - makeRegHelper :: Name -> DecsQ makeRegHelper regOptTypeName = do Just sMethodTypeName <- lookupTypeName "SMethod" @@ -170,7 +81,14 @@ makeRegHelper regOptTypeName = do -> x |] return [typSig, fun] --- | Generates a datatype +-- | @makeExtendingDatatype name extends fields@ generates a record datatype +-- that contains all the fields of @extends@, plus the additional fields in +-- @fields@. +-- e.g. +-- data Foo = { a :: Int } +-- makeExtendingDatatype "bar" [''Foo] [("b", [t| String |])] +-- Will generate +-- data Bar = { a :: Int, b :: String } makeExtendingDatatype :: String -> [Name] -> [(String, TypeQ)] -> DecsQ makeExtendingDatatype datatypeNameStr extends fields = do extendFields <- fmap concat $ forM extends $ \e -> do From bc3d2e79c807ab482bda352ec96aa6af30ae17c1 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 17 Aug 2020 12:51:32 +0100 Subject: [PATCH 22/63] Move out synchronisation stuff from DataTypesJSON --- .../Haskell/LSP/Types/Capabilities.hs | 1 + .../Haskell/LSP/Types/ClientCapabilities.hs | 22 -- .../src/Language/Haskell/LSP/Types/Common.hs | 4 +- .../Haskell/LSP/Types/DataTypesJSON.hs | 354 ------------------ .../Language/Haskell/LSP/Types/Diagnostic.hs | 61 ++- .../src/Language/Haskell/LSP/Types/Message.hs | 4 +- .../Haskell/LSP/Types/ServerCapabilities.hs | 258 +------------ .../Haskell/LSP/Types/TextDocument.hs | 186 ++++++++- .../Haskell/LSP/Types/WorkspaceEdit.hs | 29 +- 9 files changed, 237 insertions(+), 682 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 98017f100..e1357ac9d 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -219,6 +219,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth PublishDiagnosticsClientCapabilities (since 3 7 True) (since 3 15 publishDiagnosticsTagsCapabilities) + (since 3 15 True) publishDiagnosticsTagsCapabilities = PublishDiagnosticsTagsClientCapabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 89a5b6989..970ef96e6 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -660,28 +660,6 @@ data ColorProviderClientCapabilities = deriveJSON lspOptions ''ColorProviderClientCapabilities --- ------------------------------------- - -data PublishDiagnosticsTagsClientCapabilities = - PublishDiagnosticsTagsClientCapabilities - { -- | The tags supported by the client. - _valueSet :: List DiagnosticTag - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''PublishDiagnosticsTagsClientCapabilities - -data PublishDiagnosticsClientCapabilities = - PublishDiagnosticsClientCapabilities - { -- | Whether the clients accepts diagnostics with related information. - _relatedInformation :: Maybe Bool - -- | Client supports the tag property to provide metadata about a - -- diagnostic. - -- - -- Clients supporting tags have to handle unknown tags gracefully. - , _tagSupport :: Maybe PublishDiagnosticsTagsClientCapabilities - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''PublishDiagnosticsClientCapabilities -- ------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index cd72dfe6f..d907749a0 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -16,7 +16,7 @@ import GHC.Generics -- converting to and from JSON. data a |? b = L a | R b - deriving (Read,Show,Eq) + deriving (Read,Show,Eq,Generic) infixr |? instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where @@ -26,6 +26,8 @@ instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where parseJSON v = L <$> parseJSON v <|> R <$> parseJSON v +instance (NFData a, NFData b) => NFData (a |? b) + -- | This data type is used to host a FromJSON instance for the encoding used by -- elisp, where an empty list shows up as "null" newtype List a = List [a] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index f6e93c8a4..fd5370f56 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -22,14 +22,11 @@ import Data.Scientific (floatingOrInteger) import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.LSP.Types.ClientCapabilities -import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.Common -import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.ServerCapabilities -import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.WorkspaceEdit @@ -532,337 +529,6 @@ data ConfigurationParams = deriveJSON lspOptions ''ConfigurationParams --- --------------------------------------------------------------------- -{- -DidOpenTextDocument Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#didopentextdocument-notification - -The document open notification is sent from the client to the server to signal -newly opened text documents. The document's truth is now managed by the client -and the server must not try to read the document's truth using the document's -uri. - -Notification: - - method: 'textDocument/didOpen' - params: DidOpenTextDocumentParams defined as follows: - -interface DidOpenTextDocumentParams { - /** - * The document that was opened. - */ - textDocument: TextDocumentItem; -} - -Registration Options: TextDocumentRegistrationOptions --} - -data DidOpenTextDocumentParams = - DidOpenTextDocumentParams { - _textDocument :: TextDocumentItem - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DidOpenTextDocumentParams - --- --------------------------------------------------------------------- -{- -DidChangeTextDocument Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#didchangetextdocument-notification - - Changed: The document change notification is sent from the client to the - server to signal changes to a text document. In 2.0 the shape of the params - has changed to include proper version numbers and language ids. - -Notification: - - method: 'textDocument/didChange' - params: DidChangeTextDocumentParams defined as follows: - -interface DidChangeTextDocumentParams { - /** - * The document that did change. The version number points - * to the version after all provided content changes have - * been applied. - */ - textDocument: VersionedTextDocumentIdentifier; - - /** - * The actual content changes. - */ - contentChanges: TextDocumentContentChangeEvent[]; -} - -/** - * An event describing a change to a text document. If range and rangeLength are omitted - * the new text is considered to be the full content of the document. - */ -interface TextDocumentContentChangeEvent { - /** - * The range of the document that changed. - */ - range?: Range; - - /** - * The length of the range that got replaced. - */ - rangeLength?: number; - - /** - * The new text of the document. - */ - text: string; -} --} -data TextDocumentContentChangeEvent = - TextDocumentContentChangeEvent - { _range :: Maybe Range - , _rangeLength :: Maybe Int - , _text :: Text - } deriving (Read,Show,Eq) - -deriveJSON lspOptions { omitNothingFields = True } ''TextDocumentContentChangeEvent - --- ------------------------------------- - -data DidChangeTextDocumentParams = - DidChangeTextDocumentParams - { _textDocument :: VersionedTextDocumentIdentifier - , _contentChanges :: List TextDocumentContentChangeEvent - } deriving (Show,Read,Eq) - -deriveJSON lspOptions ''DidChangeTextDocumentParams - -{- -New in 3.0 ----------- - -Registration Options: TextDocumentChangeRegistrationOptions defined as follows: - -/** - * Descibe options to be used when registered for text document change events. - */ -export interface TextDocumentChangeRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * How documents are synced to the server. See TextDocumentSyncKind.Full - * and TextDocumentSyncKindIncremental. - */ - syncKind: number; -} --} - -makeExtendingDatatype "TextDocumentChangeRegistrationOptions" - [''TextDocumentRegistrationOptions] - [("_syncKind", [t| TextDocumentSyncKind |])] - -deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions - --- --------------------------------------------------------------------- -{- - -New in 3.0 ----------- - -WillSaveTextDocument Notification - -The document will save notification is sent from the client to the server before -the document is actually saved. - -Notification: - - method: 'textDocument/willSave' - params: WillSaveTextDocumentParams defined as follows: - -/** - * The parameters send in a will save text document notification. - */ -export interface WillSaveTextDocumentParams { - /** - * The document that will be saved. - */ - textDocument: TextDocumentIdentifier; - - /** - * The 'TextDocumentSaveReason'. - */ - reason: number; -} - -/** - * Represents reasons why a text document is saved. - */ -export namespace TextDocumentSaveReason { - - /** - * Manually triggered, e.g. by the user pressing save, by starting debugging, - * or by an API call. - */ - export const Manual = 1; - - /** - * Automatic after a delay. - */ - export const AfterDelay = 2; - - /** - * When the editor lost focus. - */ - export const FocusOut = 3; -} -Registration Options: TextDocumentRegistrationOptions --} - -data TextDocumentSaveReason - = SaveManual - -- ^ Manually triggered, e.g. by the user pressing save, by starting - -- debugging, or by an API call. - | SaveAfterDelay -- ^ Automatic after a delay - | SaveFocusOut -- ^ When the editor lost focus - deriving (Show, Read, Eq) - -instance A.ToJSON TextDocumentSaveReason where - toJSON SaveManual = A.Number 1 - toJSON SaveAfterDelay = A.Number 2 - toJSON SaveFocusOut = A.Number 3 - -instance A.FromJSON TextDocumentSaveReason where - parseJSON (A.Number 1) = pure SaveManual - parseJSON (A.Number 2) = pure SaveAfterDelay - parseJSON (A.Number 3) = pure SaveFocusOut - parseJSON _ = mempty - -data WillSaveTextDocumentParams = - WillSaveTextDocumentParams - { _textDocument :: TextDocumentIdentifier - , _reason :: TextDocumentSaveReason - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''WillSaveTextDocumentParams - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -WillSaveWaitUntilTextDocument Request - -The document will save request is sent from the client to the server before the -document is actually saved. The request can return an array of TextEdits which -will be applied to the text document before it is saved. Please note that -clients might drop results if computing the text edits took too long or if a -server constantly fails on this request. This is done to keep the save fast and -reliable. - -Request: - - method: 'textDocument/willSaveWaitUntil' - params: WillSaveTextDocumentParams - -Response: - - result: TextEdit[] - error: code and message set in case an exception happens during the willSaveWaitUntil request. - -Registration Options: TextDocumentRegistrationOptions --} - --- --------------------------------------------------------------------- -{- -DidSaveTextDocument Notification - -The document save notification is sent from the client to the server when the document was saved in the client. - -Client Capability: - -property name (optional): textDocument.synchronization.didSave -property type: boolean -The capability indicates that the client supports textDocument/didSave notifications. - -Server Capability: - -property name (optional): textDocumentSync.save -property type: boolean | SaveOptions where SaveOptions is defined as follows: -export interface SaveOptions { - /** - * The client is supposed to include the content on save. - */ - includeText?: boolean; -} -The capability indicates that the server is interested in textDocument/didSave notifications. - -Registration Options: TextDocumentSaveRegistrationOptions defined as follows: - -export interface TextDocumentSaveRegistrationOptions extends TextDocumentRegistrationOptions { - /** - * The client is supposed to include the content on save. - */ - includeText?: boolean; -} -Notification: - -method: 'textDocument/didSave' -params: DidSaveTextDocumentParams defined as follows: -interface DidSaveTextDocumentParams { - /** - * The document that was saved. - */ - textDocument: TextDocumentIdentifier; - - /** - * Optional the content when saved. Depends on the includeText value - * when the save notification was requested. - */ - text?: string; -} --} -data DidSaveTextDocumentParams = - DidSaveTextDocumentParams - { _textDocument :: TextDocumentIdentifier - , _text :: Maybe Text - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DidSaveTextDocumentParams - -makeExtendingDatatype "TextDocumentSaveRegistrationOptions" - [''TextDocumentRegistrationOptions] - [("_saveOptions", [t| SaveOptions |])] - -deriveJSON lspOptions ''TextDocumentSaveRegistrationOptions - --- --------------------------------------------------------------------- -{- -DidCloseTextDocument Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#didclosetextdocument-notification - -The document close notification is sent from the client to the server when the -document got closed in the client. The document's truth now exists where the -document's uri points to (e.g. if the document's uri is a file uri the truth now -exists on disk). - - Changed: In 2.0 the params are of type DidCloseTextDocumentParams which - contains a reference to a text document. - -Notification: - - method: 'textDocument/didClose' - params: DidCloseTextDocumentParams defined as follows: - -interface DidCloseTextDocumentParams { - /** - * The document that was closed. - */ - textDocument: TextDocumentIdentifier; -} --} -data DidCloseTextDocumentParams = - DidCloseTextDocumentParams - { _textDocument :: TextDocumentIdentifier - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DidCloseTextDocumentParams - -- --------------------------------------------------------------------- {- DidChangeWatchedFiles Notification @@ -978,14 +644,6 @@ interface PublishDiagnosticsParams { } -} -data PublishDiagnosticsParams = - PublishDiagnosticsParams - { _uri :: Uri - , _diagnostics :: List Diagnostic - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''PublishDiagnosticsParams - -- --------------------------------------------------------------------- {- @@ -1040,18 +698,6 @@ error: code and message set in case an exception happens during the definition r -- {"jsonrpc":"2.0","id":1,"method":"textDocument/definition","params":{"textDocument":{"uri":"file:///tmp/Foo.hs"},"position":{"line":1,"character":8}}} -data LocationResponseParams = SingleLoc Location | MultiLoc [Location] - deriving (Eq,Read,Show) - -instance A.ToJSON LocationResponseParams where - toJSON (SingleLoc x) = toJSON x - toJSON (MultiLoc xs) = toJSON xs - -instance A.FromJSON LocationResponseParams where - parseJSON xs@(A.Array _) = MultiLoc <$> parseJSON xs - parseJSON x = SingleLoc <$> parseJSON x - - -- --------------------------------------------------------------------- {- Workspace Symbols Request diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs index 69b63e7a8..3897df4d7 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs @@ -1,17 +1,18 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} module Language.Haskell.LSP.Types.Diagnostic where import Control.DeepSeq import qualified Data.Aeson as A import Data.Aeson.TH -import Data.Scientific import Data.Text import GHC.Generics import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- @@ -183,27 +184,63 @@ interface Diagnostic { } -} -data NumberOrString = - NumberValue Scientific - | StringValue Text - deriving (Show, Read, Eq, Ord, Generic) - -instance NFData NumberOrString - -deriveJSON lspOptions { sumEncoding = A.UntaggedValue } ''NumberOrString - type DiagnosticSource = Text data Diagnostic = Diagnostic { _range :: Range , _severity :: Maybe DiagnosticSeverity - , _code :: Maybe NumberOrString + , _code :: Maybe (Int |? String) , _source :: Maybe DiagnosticSource , _message :: Text , _tags :: Maybe (List DiagnosticTag) , _relatedInformation :: Maybe (List DiagnosticRelatedInformation) - } deriving (Show, Read, Eq, Ord, Generic) + } deriving (Show, Read, Eq, Generic) instance NFData Diagnostic deriveJSON lspOptions ''Diagnostic + +-- ------------------------------------- + +data PublishDiagnosticsTagsClientCapabilities = + PublishDiagnosticsTagsClientCapabilities + { -- | The tags supported by the client. + _valueSet :: List DiagnosticTag + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''PublishDiagnosticsTagsClientCapabilities + +data PublishDiagnosticsClientCapabilities = + PublishDiagnosticsClientCapabilities + { -- | Whether the clients accepts diagnostics with related information. + _relatedInformation :: Maybe Bool + -- | Client supports the tag property to provide metadata about a + -- diagnostic. + -- + -- Clients supporting tags have to handle unknown tags gracefully. + -- + -- Since LSP 3.15.0 + , _tagSupport :: Maybe PublishDiagnosticsTagsClientCapabilities + -- | Whether the client interprets the version property of the + -- @textDocument/publishDiagnostics@ notification's parameter. + -- + -- Since LSP 3.15.0 + , _versionSupport :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''PublishDiagnosticsClientCapabilities + +data PublishDiagnosticsParams = + PublishDiagnosticsParams + { -- | The URI for which diagnostic information is reported. + _uri :: Uri + -- | Optional the version number of the document the diagnostics are + -- published for. + -- + -- Since LSP 3.15.0 + , _version :: Maybe Int + -- | An array of diagnostic information items. + , _diagnostics :: List Diagnostic + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''PublishDiagnosticsParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 18c59a6c5..2a9e930f9 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -26,9 +26,11 @@ import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition +import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover @@ -42,7 +44,7 @@ import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.DocumentSymbol +import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.Window diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs index 12ed90158..07f9adce1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ServerCapabilities.hs @@ -17,269 +17,19 @@ import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.DocumentSymbol +import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils --- --------------------------------------------------------------------- -{- -The server can signal the following capabilities: - -/** - * Defines how the host (editor) should sync document changes to the language server. - */ -enum TextDocumentSyncKind { - /** - * Documents should not be synced at all. - */ - None = 0, - /** - * Documents are synced by always sending the full content of the document. - */ - Full = 1, - /** - * Documents are synced by sending the full content on open. After that only incremental - * updates to the document are sent. - */ - Incremental = 2 -} --} - --- ^ Note: Omitting this parameter from the capabilities is effectively a fourth --- state, where DidSave events are generated without sending document contents. -data TextDocumentSyncKind = TdSyncNone - | TdSyncFull - | TdSyncIncremental - deriving (Read,Eq,Show) - -instance ToJSON TextDocumentSyncKind where - toJSON TdSyncNone = Number 0 - toJSON TdSyncFull = Number 1 - toJSON TdSyncIncremental = Number 2 - -instance FromJSON TextDocumentSyncKind where - parseJSON (Number 0) = pure TdSyncNone - parseJSON (Number 1) = pure TdSyncFull - parseJSON (Number 2) = pure TdSyncIncremental - parseJSON _ = mempty - - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- -/** - * Save options. - */ -export interface SaveOptions { - /** - * The client is supposed to include the content on save. - */ - includeText?: boolean; -} --} -data SaveOptions = - SaveOptions - { -- | The client is supposed to include the content on save. - _includeText :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''SaveOptions - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -export interface TextDocumentSyncOptions { - /** - * Open and close notifications are sent to the server. - */ - openClose?: boolean; - /** - * Change notificatins are sent to the server. See TextDocumentSyncKind.None, TextDocumentSyncKind.Full - * and TextDocumentSyncKindIncremental. - */ - change?: number; - /** - * Will save notifications are sent to the server. - */ - willSave?: boolean; - /** - * Will save wait until requests are sent to the server. - */ - willSaveWaitUntil?: boolean; - /** - * Save notifications are sent to the server. - */ - save?: SaveOptions; -} --} - -data TextDocumentSyncOptions = - TextDocumentSyncOptions - { -- | Open and close notifications are sent to the server. - _openClose :: Maybe Bool - - -- | Change notificatins are sent to the server. See - -- TextDocumentSyncKind.None, TextDocumentSyncKind.Full and - -- TextDocumentSyncKindIncremental. - , _change :: Maybe TextDocumentSyncKind - - -- | Will save notifications are sent to the server. - , _willSave :: Maybe Bool - - -- | Will save wait until requests are sent to the server. - , _willSaveWaitUntil :: Maybe Bool - - -- | Save notifications are sent to the server. - , _save :: Maybe SaveOptions - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''TextDocumentSyncOptions - --- --------------------------------------------------------------------- -{- - -Extended in 3.0 ---------------- - -interface ServerCapabilities { - /** - * Defines how text documents are synced. Is either a detailed structure defining each notification or - * for backwards compatibility the TextDocumentSyncKind number. If omitted it defaults to `TextDocumentSyncKind.None`. - */ - textDocumentSync?: TextDocumentSyncOptions | number; - /** - * The server provides hover support. - */ - hoverProvider?: boolean; - /** - * The server provides completion support. - */ - completionProvider?: CompletionOptions; - /** - * The server provides signature help support. - */ - signatureHelpProvider?: SignatureHelpOptions; - /** - * The server provides goto definition support. - */ - definitionProvider?: boolean; - /** - * The server provides Goto Type Definition support. - * - * Since 3.6.0 - */ - typeDefinitionProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides Goto Implementation support. - * - * Since 3.6.0 - */ - implementationProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides find references support. - */ - referencesProvider?: boolean; - /** - * The server provides document highlight support. - */ - documentHighlightProvider?: boolean; - /** - * The server provides document symbol support. - */ - documentSymbolProvider?: boolean; - /** - * The server provides workspace symbol support. - */ - workspaceSymbolProvider?: boolean; - /** - * The server provides code actions. The `CodeActionOptions` return type is only - * valid if the client signals code action literal support via the property - * `textDocument.codeAction.codeActionLiteralSupport`. - */ - codeActionProvider?: boolean | CodeActionOptions; - /** - * The server provides code lens. - */ - codeLensProvider?: CodeLensOptions; - /** - * The server provides document formatting. - */ - documentFormattingProvider?: boolean; - /** - * The server provides document range formatting. - */ - documentRangeFormattingProvider?: boolean; - /** - * The server provides document formatting on typing. - */ - documentOnTypeFormattingProvider?: DocumentOnTypeFormattingOptions; - /** - * The server provides rename support. - */ - renameProvider?: boolean; - /** - * The server provides document link support. - */ - documentLinkProvider?: DocumentLinkOptions; - /** - * The server provides color provider support. - * - * Since 3.6.0 - */ - colorProvider?: boolean | ColorProviderOptions | (ColorProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides folding provider support. - * - * Since 3.10.0 - */ - foldingRangeProvider?: boolean | FoldingRangeProviderOptions | (FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions); - /** - * The server provides execute command support. - */ - executeCommandProvider?: ExecuteCommandOptions; - /** - * Workspace specific server capabilities - */ - workspace?: { - /** - * The server supports workspace folder. - * - * Since 3.6.0 - */ - workspaceFolders?: { - /** - * The server has support for workspace folders - */ - supported?: boolean; - /** - * Whether the server wants to receive workspace folder - * change notifications. - * - * If a strings is provided the string is treated as a ID - * under which the notification is registered on the client - * side. The ID can be used to unregister for these events - * using the `client/unregisterCapability` request. - */ - changeNotifications?: string | boolean; - } - } - /** - * Experimental server capabilities. - */ - experimental?: any; -} --} - -- --------------------------------------------------------------------- data WorkspaceFoldersServerCapabilities = @@ -365,6 +115,8 @@ data ServerCapabilities = , _foldingRangeProvider :: Maybe (Bool |? FoldingRangeOptions |? FoldingRangeRegistrationOptions) -- | The server provides execute command support. , _executeCommandProvider :: Maybe ExecuteCommandOptions + -- | The server provides selection range support. Since LSP 3.15 + , _selectionRangeProvider :: Maybe (Bool |? SelectionRangeOptions |? SelectionRangeRegistrationOptions) -- | The server provides workspace symbol support. , _workspaceSymbolProvider :: Maybe Bool -- | Workspace specific server capabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs index d923b71cb..a77010d33 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} module Language.Haskell.LSP.Types.TextDocument where +import Data.Aeson import Data.Aeson.TH import Data.Text ( Text ) +import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Uri @@ -30,9 +33,14 @@ data TextDocumentIdentifier = TextDocumentIdentifier { _uri :: Uri } deriving (Show, Read, Eq) - deriveJSON lspOptions ''TextDocumentIdentifier +type TextDocumentVersion = Maybe Int + +makeExtendingDatatype "VersionedTextDocumentIdentifier" [''TextDocumentIdentifier] + [ ("_version", [t| TextDocumentVersion |])] +deriveJSON lspOptions ''VersionedTextDocumentIdentifier + {- TextDocumentItem @@ -98,26 +106,57 @@ interface TextDocumentPositionParams { -} data TextDocumentPositionParams = TextDocumentPositionParams - { _textDocument :: TextDocumentIdentifier - , _position :: Position + { -- | The text document. + _textDocument :: TextDocumentIdentifier + , -- | The position inside the text document. + _position :: Position } deriving (Show, Read, Eq) deriveJSON lspOptions ''TextDocumentPositionParams +-- ------------------------------------- + +-- Text document synchronisation + +-- | Defines how the host (editor) should sync document changes to the language server. +data TextDocumentSyncKind + = -- | Documents should not be synced at all. + TdSyncNone + | -- | Documents are synced by always sending the full content of the document. + TdSyncFull + | -- | Documents are synced by sending the full content on open. After that only incremental updates to the document are send. + TdSyncIncremental + deriving (Read, Eq, Show) + +instance ToJSON TextDocumentSyncKind where + toJSON TdSyncNone = Number 0 + toJSON TdSyncFull = Number 1 + toJSON TdSyncIncremental = Number 2 + +instance FromJSON TextDocumentSyncKind where + parseJSON (Number 0) = pure TdSyncNone + parseJSON (Number 1) = pure TdSyncFull + parseJSON (Number 2) = pure TdSyncIncremental + parseJSON _ = mempty + +data TextDocumentSyncOptions = + TextDocumentSyncOptions + { -- | Open and close notifications are sent to the server. If omitted open + -- close notification should not be sent. + _openClose :: Maybe Bool + , -- | Change notifications are sent to the server. See + -- TextDocumentSyncKind.None, TextDocumentSyncKind.Full + -- and TextDocumentSyncKind.Incremental. If omitted it defaults to + -- TextDocumentSyncKind.None. + _change :: Maybe TextDocumentSyncKind + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''TextDocumentSyncOptions -- ------------------------------------- {- Since most of the registration options require to specify a document selector there is a base interface that can be used. - -export interface TextDocumentRegistrationOptions { - /** - * A document selector to identify the scope of the registration. If set to null - * the document selector provided on the client side will be used. - */ - documentSelector: DocumentSelector | null; -} -} data TextDocumentRegistrationOptions = @@ -126,3 +165,128 @@ data TextDocumentRegistrationOptions = } deriving (Show, Read, Eq) deriveJSON lspOptions ''TextDocumentRegistrationOptions + +-- ------------------------------------- + +data DidOpenTextDocumentParams = + DidOpenTextDocumentParams + { -- | The document that was opened. + _textDocument :: TextDocumentItem + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DidOpenTextDocumentParams + +-- ------------------------------------- + +makeExtendingDatatype "TextDocumentChangeRegistrationOptions" + [''TextDocumentRegistrationOptions] + [("_syncKind", [t| TextDocumentSyncKind |])] + +deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions + +{-# DEPRECATED _rangeLength "Use _range instead" #-} +data TextDocumentContentChangeEvent = + TextDocumentContentChangeEvent + { -- | The range of the document that changed. + _range :: Maybe Range + -- | The optional length of the range that got replaced. + , _rangeLength :: Maybe Int + -- | The new text for the provided range, if provided. + -- Otherwise the new text of the whole document. + , _text :: Text + } + deriving (Read,Show,Eq) + +deriveJSON lspOptions ''TextDocumentContentChangeEvent + +-- ------------------------------------- + +data DidChangeTextDocumentParams = + DidChangeTextDocumentParams + { -- | The document that did change. The version number points + -- to the version after all provided content changes have + -- been applied. + _textDocument :: VersionedTextDocumentIdentifier + -- | The actual content changes. The content changes describe single state changes + -- to the document. So if there are two content changes c1 (at array index 0) and + -- c2 (at array index 1) for a document in state S then c1 moves the document from + -- S to S' and c2 from S' to S''. So c1 is computed on the state S and c2 is computed + -- on the state S'. + -- + -- To mirror the content of a document using change events use the following approach: + -- - start with the same initial content + -- - apply the 'textDocument/didChange' notifications in the order you recevie them. + -- - apply the `TextDocumentContentChangeEvent`s in a single notification in the order + -- you receive them. + , _contentChanges :: List TextDocumentContentChangeEvent + } deriving (Show,Read,Eq) + +deriveJSON lspOptions ''DidChangeTextDocumentParams + +-- ------------------------------------- + +data TextDocumentSaveReason + = SaveManual + -- ^ Manually triggered, e.g. by the user pressing save, by starting + -- debugging, or by an API call. + | SaveAfterDelay -- ^ Automatic after a delay + | SaveFocusOut -- ^ When the editor lost focus + deriving (Show, Read, Eq) + +instance ToJSON TextDocumentSaveReason where + toJSON SaveManual = Number 1 + toJSON SaveAfterDelay = Number 2 + toJSON SaveFocusOut = Number 3 + +instance FromJSON TextDocumentSaveReason where + parseJSON (Number 1) = pure SaveManual + parseJSON (Number 2) = pure SaveAfterDelay + parseJSON (Number 3) = pure SaveFocusOut + parseJSON _ = mempty + +data WillSaveTextDocumentParams = + WillSaveTextDocumentParams + { -- | The document that will be saved. + _textDocument :: TextDocumentIdentifier + -- | The 'TextDocumentSaveReason'. + , _reason :: TextDocumentSaveReason + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''WillSaveTextDocumentParams + +-- ------------------------------------- + +data SaveOptions = + SaveOptions + { -- | The client is supposed to include the content on save. + _includeText :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''SaveOptions + +makeExtendingDatatype "TextDocumentSaveRegistrationOptions" + [''TextDocumentRegistrationOptions] + [("_includeText", [t| Maybe Bool |])] + +deriveJSON lspOptions ''TextDocumentSaveRegistrationOptions + +data DidSaveTextDocumentParams = + DidSaveTextDocumentParams + { -- | The document that was saved. + _textDocument :: TextDocumentIdentifier + -- | Optional the content when saved. Depends on the includeText value + -- when the save notification was requested. + , _text :: Maybe Text + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''DidSaveTextDocumentParams + +-- ------------------------------------- + +data DidCloseTextDocumentParams = + DidCloseTextDocumentParams + { -- | The document that was closed. + _textDocument :: TextDocumentIdentifier + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''DidCloseTextDocumentParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs index 7d621c2b4..3685d5632 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs @@ -12,6 +12,7 @@ import qualified Data.Text as T import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Utils @@ -48,34 +49,6 @@ data TextEdit = deriveJSON lspOptions ''TextEdit --- --------------------------------------------------------------------- -{- -VersionedTextDocumentIdentifier - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#versionedtextdocumentidentifier - - New: An identifier to denote a specific version of a text document. - -interface VersionedTextDocumentIdentifier extends TextDocumentIdentifier { - /** - * The version number of this document. If a versioned text document identifier - * is sent from the server to the client and the file is not open in the editor - * (the server has not received an open notification before) the server can send - * `null` to indicate that the version is known and the content on disk is the - * truth (as speced with document content ownership) - */ - version: number | null; --} - -type TextDocumentVersion = Maybe Int - -data VersionedTextDocumentIdentifier = - VersionedTextDocumentIdentifier - { _uri :: Uri - , _version :: TextDocumentVersion - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''VersionedTextDocumentIdentifier -- --------------------------------------------------------------------- {- From 814c4e872c3e7e09cfdb71833d89765600ba654e Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 17 Aug 2020 13:02:05 +0100 Subject: [PATCH 23/63] Move out executeCommand stuff from DataTypesJSON --- .../Haskell/LSP/Types/ClientCapabilities.hs | 11 +-- .../src/Language/Haskell/LSP/Types/Command.hs | 80 +++++++------------ .../Haskell/LSP/Types/DataTypesJSON.hs | 16 ---- .../Haskell/LSP/Types/Registration.hs | 1 + 4 files changed, 33 insertions(+), 75 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 970ef96e6..420f279e8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -8,6 +8,7 @@ import qualified Data.Aeson as A import Data.Default import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens +import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Diagnostic @@ -206,16 +207,6 @@ deriveJSON lspOptions ''WorkspaceSymbolClientCapabilities -- ------------------------------------- -data ExecuteCommandClientCapabilities = - ExecuteCommandClientCapabilities - { _dynamicRegistration :: Maybe Bool -- ^Execute command supports dynamic - -- registration. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ExecuteCommandClientCapabilities - --- ------------------------------------- - data WorkspaceClientCapabilities = WorkspaceClientCapabilities { -- | The client supports applying batch edits to the workspace by supporting diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs index 81f71ce82..a6a9bc2c4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} module Language.Haskell.LSP.Types.Command where @@ -6,64 +7,45 @@ import Data.Aeson import Data.Aeson.TH import Data.Text import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Utils --- --------------------------------------------------------------------- -{- -Command +-- ------------------------------------- -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#command +data ExecuteCommandClientCapabilities = + ExecuteCommandClientCapabilities + { _dynamicRegistration :: Maybe Bool -- ^Execute command supports dynamic + -- registration. + } deriving (Show, Read, Eq) -Represents a reference to a command. Provides a title which will be used to -represent a command in the UI. Commands are identitifed using a string -identifier and the protocol currently doesn't specify a set of well known -commands. So executing a command requires some tool extension code. +deriveJSON lspOptions ''ExecuteCommandClientCapabilities -interface Command { - /** - * Title of the command, like `save`. - */ - title: string; - /** - * The identifier of the actual command handler. - */ - command: string; - /** - * Arguments that the command handler should be - * invoked with. - */ - arguments?: any[]; -} --} +-- ------------------------------------- -data Command = - Command - { _title :: Text - , _command :: Text - , _arguments :: Maybe (List Value) - } deriving (Show, Read, Eq) +makeExtendingDatatype "ExecuteCommandOptions" [''WorkDoneProgressOptions] + [("_commands", [t| List String |])] +deriveJSON lspOptions ''ExecuteCommandOptions -deriveJSON lspOptions ''Command +makeExtendingDatatype "ExecuteCommandRegistrationOptions" [''ExecuteCommandOptions] [] +deriveJSON lspOptions ''ExecuteCommandRegistrationOptions -{- -New in 3.0 ------------ +-- ------------------------------------- -/** - * Execute command options. - */ -export interface ExecuteCommandOptions { - /** - * The commands to be executed on the server - */ - commands: string[] -} --} +makeExtendingDatatype "ExecuteCommandParams" [''WorkDoneProgressParams] + [ ("_command", [t| Text |]) + , ("_arguments", [t| Maybe (List Value ) |]) + ] +deriveJSON lspOptions ''ExecuteCommandParams -data ExecuteCommandOptions = - ExecuteCommandOptions - { -- | The commands to be executed on the server - _commands :: List Text +data Command = + Command + { -- | Title of the command, like @save@. + _title :: Text + , -- | The identifier of the actual command handler. + _command :: Text + , -- | Arguments that the command handler should be invoked with. + _arguments :: Maybe (List Value) } deriving (Show, Read, Eq) -deriveJSON lspOptions ''ExecuteCommandOptions +deriveJSON lspOptions ''Command + diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index fd5370f56..fd1113ca4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -786,22 +786,6 @@ export interface ExecuteCommandRegistrationOptions { } -} -data ExecuteCommandParams = - ExecuteCommandParams - { _command :: Text -- ^ The identifier of the actual command handler. - , _arguments :: Maybe (List A.Value) -- ^ Arguments that the command should be invoked with. - , _workDoneToken :: Maybe ProgressToken -- ^ An optional token that a server can use to report work done progress. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ExecuteCommandParams - -data ExecuteCommandRegistrationOptions = - ExecuteCommandRegistrationOptions - { _commands :: List Text - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ExecuteCommandRegistrationOptions - -- --------------------------------------------------------------------- {- New in 3.0 diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index 751122bf6..9ca5e9c4a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -31,6 +31,7 @@ import Data.Void (Void) import GHC.Generics import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens +import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.DataTypesJSON From 675300377080d576c0f0537ba186a7132b39d351 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 18 Aug 2020 01:13:44 +0100 Subject: [PATCH 24/63] Finish stripping out DataTypesJSON Also add resourceOperations and failureHandling to WorkspaceEditClientCWorkspaceEditClientCapabilities --- haskell-lsp-types/haskell-lsp-types.cabal | 8 +- .../src/Language/Haskell/LSP/Types.hs | 12 +- .../Haskell/LSP/Types/Cancellation.hs | 27 + .../Haskell/LSP/Types/Capabilities.hs | 15 +- .../Haskell/LSP/Types/ClientCapabilities.hs | 650 +------------ .../Haskell/LSP/Types/Configuration.hs | 42 + .../Haskell/LSP/Types/DataTypesJSON.hs | 900 ------------------ .../Language/Haskell/LSP/Types/Initialize.hs | 98 ++ .../src/Language/Haskell/LSP/Types/Lens.hs | 48 +- .../src/Language/Haskell/LSP/Types/Message.hs | 68 +- .../Haskell/LSP/Types/Registration.hs | 82 +- .../Haskell/LSP/Types/TextDocument.hs | 26 + .../Haskell/LSP/Types/WatchedFiles.hs | 113 +++ .../Haskell/LSP/Types/WorkspaceEdit.hs | 158 +-- .../Haskell/LSP/Types/WorkspaceSymbol.hs | 76 ++ 15 files changed, 570 insertions(+), 1753 deletions(-) create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Cancellation.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Configuration.hs delete mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/Initialize.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/WatchedFiles.hs create mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceSymbol.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index 0bd4cfe97..162ee3789 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -21,13 +21,14 @@ library , Language.Haskell.LSP.Types.Capabilities , Language.Haskell.LSP.Types.Lens , Data.IxMap - other-modules: Language.Haskell.LSP.Types.ClientCapabilities + other-modules: Language.Haskell.LSP.Types.Cancellation + , Language.Haskell.LSP.Types.ClientCapabilities , Language.Haskell.LSP.Types.CodeAction , Language.Haskell.LSP.Types.CodeLens , Language.Haskell.LSP.Types.Command , Language.Haskell.LSP.Types.Common , Language.Haskell.LSP.Types.Completion - , Language.Haskell.LSP.Types.DataTypesJSON + , Language.Haskell.LSP.Types.Configuration , Language.Haskell.LSP.Types.Declaration , Language.Haskell.LSP.Types.Definition , Language.Haskell.LSP.Types.Diagnostic @@ -40,6 +41,7 @@ library , Language.Haskell.LSP.Types.Formatting , Language.Haskell.LSP.Types.Hover , Language.Haskell.LSP.Types.Implementation + , Language.Haskell.LSP.Types.Initialize , Language.Haskell.LSP.Types.Location , Language.Haskell.LSP.Types.LspId , Language.Haskell.LSP.Types.MarkupContent @@ -59,8 +61,10 @@ library , Language.Haskell.LSP.Types.Uri , Language.Haskell.LSP.Types.Utils , Language.Haskell.LSP.Types.Window + , Language.Haskell.LSP.Types.WatchedFiles , Language.Haskell.LSP.Types.WorkspaceEdit , Language.Haskell.LSP.Types.WorkspaceFolders + , Language.Haskell.LSP.Types.WorkspaceSymbol -- other-extensions: ghc-options: -Wall build-depends: base >= 4.9 && < 4.15 diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 18f938498..cdd41bbeb 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -1,10 +1,11 @@ module Language.Haskell.LSP.Types - ( module Language.Haskell.LSP.Types.DataTypesJSON + ( module Language.Haskell.LSP.Types.Cancellation , module Language.Haskell.LSP.Types.CodeAction , module Language.Haskell.LSP.Types.CodeLens , module Language.Haskell.LSP.Types.Command , module Language.Haskell.LSP.Types.Common , module Language.Haskell.LSP.Types.Completion + , module Language.Haskell.LSP.Types.Configuration , module Language.Haskell.LSP.Types.Declaration , module Language.Haskell.LSP.Types.Definition , module Language.Haskell.LSP.Types.Diagnostic @@ -16,6 +17,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Formatting , module Language.Haskell.LSP.Types.Hover , module Language.Haskell.LSP.Types.Implementation + , module Language.Haskell.LSP.Types.Initialize , module Language.Haskell.LSP.Types.Location , module Language.Haskell.LSP.Types.LspId , module Language.Haskell.LSP.Types.MarkupContent @@ -32,18 +34,21 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.TextDocument , module Language.Haskell.LSP.Types.TypeDefinition , module Language.Haskell.LSP.Types.Uri + , module Language.Haskell.LSP.Types.WatchedFiles , module Language.Haskell.LSP.Types.Window , module Language.Haskell.LSP.Types.WorkspaceEdit , module Language.Haskell.LSP.Types.WorkspaceFolders + , module Language.Haskell.LSP.Types.WorkspaceSymbol ) where -import Language.Haskell.LSP.Types.DataTypesJSON +import Language.Haskell.LSP.Types.Cancellation import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Configuration import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic @@ -55,6 +60,7 @@ import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation +import Language.Haskell.LSP.Types.Initialize import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.MarkupContent @@ -71,6 +77,8 @@ import Language.Haskell.LSP.Types.Synonyms import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.WatchedFiles import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders +import Language.Haskell.LSP.Types.WorkspaceSymbol diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Cancellation.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Cancellation.hs new file mode 100644 index 000000000..0638da23b --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Cancellation.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DuplicateRecordFields #-} +module Language.Haskell.LSP.Types.Cancellation where + +import Data.Aeson.TH +import Language.Haskell.LSP.Types.LspId +import Language.Haskell.LSP.Types.Utils + +data CancelParams = forall m. + CancelParams + { -- | The request id to cancel. + _id :: LspId m + } + +deriving instance Read CancelParams +deriving instance Show CancelParams +instance Eq CancelParams where + (CancelParams a) == CancelParams b = + case (a,b) of + (IdInt x, IdInt y) -> x == y + (IdString x, IdString y) -> x == y + _ -> False + +deriveJSON lspOptions ''CancelParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index e1357ac9d..c9c33912c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -37,13 +37,22 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth where w = WorkspaceClientCapabilities (Just True) - (Just (WorkspaceEditClientCapabilities (Just True))) + (Just (WorkspaceEditClientCapabilities + (Just True) + (since 3 13 resourceOperations) + Nothing)) (Just (DidChangeConfigurationClientCapabilities dynamicReg)) (Just (DidChangeWatchedFilesClientCapabilities dynamicReg)) (Just symbolCapabilities) (Just (ExecuteCommandClientCapabilities dynamicReg)) (since 3 6 True) (since 3 6 True) + + resourceOperations = List + [ ResourceOperationCreate + , ResourceOperationDelete + , ResourceOperationRename + ] symbolCapabilities = WorkspaceSymbolClientCapabilities dynamicReg @@ -104,12 +113,12 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (Just codeActionCapability) (Just (CodeLensClientCapabilities dynamicReg)) (Just (DocumentLinkClientCapabilities dynamicReg (since 3 15 True))) - (since 3 6 (ColorProviderClientCapabilities dynamicReg)) + (since 3 6 (DocumentColorClientCapabilities dynamicReg)) (Just (RenameClientCapabilities dynamicReg (since 3 12 True))) (Just publishDiagnosticsCapabilities) (since 3 10 foldingRangeCapability) sync = - SynchronizationTextDocumentClientCapabilities + TextDocumentSyncClientCapabilities dynamicReg (Just True) (Just True) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 420f279e8..667c2e098 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -9,11 +9,12 @@ import Data.Default import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Command -import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Configuration import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition +import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink import Language.Haskell.LSP.Types.DocumentSymbol @@ -24,188 +25,13 @@ import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp +import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils +import Language.Haskell.LSP.Types.WatchedFiles +import Language.Haskell.LSP.Types.WorkspaceEdit +import Language.Haskell.LSP.Types.WorkspaceSymbol --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -/** - * Workspace specific client capabilities. - */ -export interface WorkspaceClientCapabilities { - /** - * The client supports applying batch edits to the workspace by supporting - * the request 'workspace/applyEdit' - */ - applyEdit?: boolean; - - /** - * Capabilities specific to `WorkspaceEdit`s - */ - workspaceEdit?: { - /** - * The client supports versioned document changes in `WorkspaceEdit`s - */ - documentChanges?: boolean; - }; - - /** - * Capabilities specific to the `workspace/didChangeConfiguration` notification. - */ - didChangeConfiguration?: { - /** - * Did change configuration notification supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `workspace/didChangeWatchedFiles` notification. - */ - didChangeWatchedFiles?: { - /** - * Did change watched files notification supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `workspace/symbol` request. - */ - symbol?: { - /** - * Symbol request supports dynamic registration. - */ - dynamicRegistration?: boolean; - - /** - * Specific capabilities for the `SymbolKind` in the `workspace/symbol` request. - */ - symbolKind?: { - /** - * The symbol kind values the client supports. When this - * property exists the client also guarantees that it will - * handle values outside its set gracefully and falls back - * to a default value when unknown. - * - * If this property is not present the client only supports - * the symbol kinds from `File` to `Array` as defined in - * the initial version of the protocol. - */ - valueSet?: SymbolKind[]; - } - }; - - /** - * Capabilities specific to the `workspace/executeCommand` request. - */ - executeCommand?: { - /** - * Execute command supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * The client has support for workspace folders. - * - * Since 3.6.0 - */ - workspaceFolders?: boolean; - - /** - * The client supports `workspace/configuration` requests. - * - * Since 3.6.0 - */ - configuration?: boolean; -} --} - --- ------------------------------------- - -data WorkspaceEditClientCapabilities = - WorkspaceEditClientCapabilities - { _documentChanges :: Maybe Bool -- ^The client supports versioned document - -- changes in `WorkspaceEdit`s - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''WorkspaceEditClientCapabilities - --- ------------------------------------- - -data DidChangeConfigurationClientCapabilities = - DidChangeConfigurationClientCapabilities - { _dynamicRegistration :: Maybe Bool -- ^Did change configuration - -- notification supports dynamic - -- registration. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DidChangeConfigurationClientCapabilities - --- ------------------------------------- - -data DidChangeWatchedFilesClientCapabilities = - DidChangeWatchedFilesClientCapabilities - { _dynamicRegistration :: Maybe Bool -- ^Did change watched files - -- notification supports dynamic - -- registration. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DidChangeWatchedFilesClientCapabilities - --- ------------------------------------- - -data WorkspaceSymbolKindClientCapabilities = - WorkspaceSymbolKindClientCapabilities - { -- | The symbol kind values the client supports. When this - -- property exists the client also guarantees that it will - -- handle values outside its set gracefully and falls back - -- to a default value when unknown. - -- - -- If this property is not present the client only supports - -- the symbol kinds from `File` to `Array` as defined in - -- the initial version of the protocol. - _valueSet :: Maybe (List SymbolKind) - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''WorkspaceSymbolKindClientCapabilities - -instance Default WorkspaceSymbolKindClientCapabilities where - def = WorkspaceSymbolKindClientCapabilities (Just $ List allKinds) - where allKinds = [ SkFile - , SkModule - , SkNamespace - , SkPackage - , SkClass - , SkMethod - , SkProperty - , SkField - , SkConstructor - , SkEnum - , SkInterface - , SkFunction - , SkVariable - , SkConstant - , SkString - , SkNumber - , SkBoolean - , SkArray - ] - -data WorkspaceSymbolClientCapabilities = - WorkspaceSymbolClientCapabilities - { _dynamicRegistration :: Maybe Bool -- ^Symbol request supports dynamic - -- registration. - , _symbolKind :: Maybe WorkspaceSymbolKindClientCapabilities -- ^ Specific capabilities for the `SymbolKind`. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''WorkspaceSymbolClientCapabilities - --- ------------------------------------- data WorkspaceClientCapabilities = WorkspaceClientCapabilities @@ -240,423 +66,11 @@ deriveJSON lspOptions ''WorkspaceClientCapabilities instance Default WorkspaceClientCapabilities where def = WorkspaceClientCapabilities def def def def def def def def --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- -/** - * Text document specific client capabilities. - */ -export interface TextDocumentClientCapabilities { - - synchronization?: { - /** - * Whether text document synchronization supports dynamic registration. - */ - dynamicRegistration?: boolean; - - /** - * The client supports sending will save notifications. - */ - willSave?: boolean; - - /** - * The client supports sending a will save request and - * waits for a response providing text edits which will - * be applied to the document before it is saved. - */ - willSaveWaitUntil?: boolean; - - /** - * The client supports did save notifications. - */ - didSave?: boolean; - } - - /** - * Capabilities specific to the `textDocument/completion` - */ - completion?: { - /** - * Whether completion supports dynamic registration. - */ - dynamicRegistration?: boolean; - - /** - * The client supports the following `CompletionItem` specific - * capabilities. - */ - completionItem?: { - /** - * Client supports snippets as insert text. - * - * A snippet can define tab stops and placeholders with `$1`, `$2` - * and `${3:foo}`. `$0` defines the final tab stop, it defaults to - * the end of the snippet. Placeholders with equal identifiers are linked, - * that is typing in one will update others too. - */ - snippetSupport?: boolean; - - /** - * Client supports commit characters on a completion item. - */ - commitCharactersSupport?: boolean - - /** - * Client supports the follow content formats for the documentation - * property. The order describes the preferred format of the client. - */ - documentationFormat?: MarkupKind[]; - - /** - * Client supports the deprecated property on a completion item. - */ - deprecatedSupport?: boolean; - - /** - * Client supports the preselect property on a completion item. - */ - preselectSupport?: boolean; - } - - completionItemKind?: { - /** - * The completion item kind values the client supports. When this - * property exists the client also guarantees that it will - * handle values outside its set gracefully and falls back - * to a default value when unknown. - * - * If this property is not present the client only supports - * the completion items kinds from `Text` to `Reference` as defined in - * the initial version of the protocol. - */ - valueSet?: CompletionItemKind[]; - }, - - /** - * The client supports to send additional context information for a - * `textDocument/completion` request. - */ - contextSupport?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/hover` - */ - hover?: { - /** - * Whether hover supports dynamic registration. - */ - dynamicRegistration?: boolean; - - /** - * Client supports the follow content formats for the content - * property. The order describes the preferred format of the client. - */ - contentFormat?: MarkupKind[]; - }; - - /** - * Capabilities specific to the `textDocument/signatureHelp` - */ - signatureHelp?: { - /** - * Whether signature help supports dynamic registration. - */ - dynamicRegistration?: boolean; - - /** - * The client supports the following `SignatureInformation` - * specific properties. - */ - signatureInformation?: { - /** - * Client supports the follow content formats for the documentation - * property. The order describes the preferred format of the client. - */ - documentationFormat?: MarkupKind[]; - }; - }; - - /** - * Capabilities specific to the `textDocument/references` - */ - references?: { - /** - * Whether references supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/documentHighlight` - */ - documentHighlight?: { - /** - * Whether document highlight supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/documentSymbol` - */ - documentSymbol?: { - /** - * Whether document symbol supports dynamic registration. - */ - dynamicRegistration?: boolean; - - /** - * Specific capabilities for the `SymbolKind`. - */ - symbolKind?: { - /** - * The symbol kind values the client supports. When this - * property exists the client also guarantees that it will - * handle values outside its set gracefully and falls back - * to a default value when unknown. - * - * If this property is not present the client only supports - * the symbol kinds from `File` to `Array` as defined in - * the initial version of the protocol. - */ - valueSet?: SymbolKind[]; - } - }; - - /** - * Capabilities specific to the `textDocument/formatting` - */ - formatting?: { - /** - * Whether formatting supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/rangeFormatting` - */ - rangeFormatting?: { - /** - * Whether range formatting supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/onTypeFormatting` - */ - onTypeFormatting?: { - /** - * Whether on type formatting supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/definition` - */ - definition?: { - /** - * Whether definition supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/typeDefinition` - * - * Since 3.6.0 - */ - typeDefinition?: { - /** - * Whether typeDefinition supports dynamic registration. If this is set to `true` - * the client supports the new `(TextDocumentRegistrationOptions & StaticRegistrationOptions)` - * return value for the corresponding server capability as well. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/implementation`. - * - * Since 3.6.0 - */ - implementation?: { - /** - * Whether implementation supports dynamic registration. If this is set to `true` - * the client supports the new `(TextDocumentRegistrationOptions & StaticRegistrationOptions)` - * return value for the corresponding server capability as well. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/codeAction` - */ - codeAction?: { - /** - * Whether code action supports dynamic registration. - */ - dynamicRegistration?: boolean; - /** - * The client support code action literals as a valid - * response of the `textDocument/codeAction` request. - * - * Since 3.8.0 - */ - codeActionLiteralSupport?: { - /** - * The code action kind is support with the following value - * set. - */ - codeActionKind: { - - /** - * The code action kind values the client supports. When this - * property exists the client also guarantees that it will - * handle values outside its set gracefully and falls back - * to a default value when unknown. - */ - valueSet: CodeActionKind[]; - }; - }; - }; - - /** - * Capabilities specific to the `textDocument/codeLens` - */ - codeLens?: { - /** - * Whether code lens supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/documentLink` - */ - documentLink?: { - /** - * Whether document link supports dynamic registration. - */ - dynamicRegistration?: boolean; - }; - - /** - * Capabilities specific to the `textDocument/documentColor` and the - * `textDocument/colorPresentation` request. - * - * Since 3.6.0 - */ - colorProvider?: { - /** - * Whether colorProvider supports dynamic registration. If this is set to `true` - * the client supports the new `(ColorProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions)` - * return value for the corresponding server capability as well. - */ - dynamicRegistration?: boolean; - } - - /** - * Capabilities specific to the `textDocument/rename` - */ - rename?: { - /** - * Whether rename supports dynamic registration. - */ - dynamicRegistration?: boolean; - /** - * The client supports testing for validity of rename operations - * before execution. - * - * Since 3.12.0 - */ - prepareSupport?: boolean; - }; - - /** - * Capabilities specific to `textDocument/publishDiagnostics`. - */ - publishDiagnostics?: { - /** - * Whether the clients accepts diagnostics with related information. - */ - relatedInformation?: boolean; - }; - - /** - * Capabilities specific to `textDocument/foldingRange` requests. - * - * Since 3.10.0 - */ - foldingRange?: { - /** - * Whether implementation supports dynamic registration for folding range providers. If this is set to `true` - * the client supports the new `(FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions)` - * return value for the corresponding server capability as well. - */ - dynamicRegistration?: boolean; - /** - * The maximum number of folding ranges that the client prefers to receive per document. The value serves as a - * hint, servers are free to follow the limit. - */ - rangeLimit?: number; - /** - * If set, the client signals that it only supports folding complete lines. If set, client will - * ignore specified `startCharacter` and `endCharacter` properties in a FoldingRange. - */ - lineFoldingOnly?: boolean; - }; -} - --} - --- ------------------------------------- - --- TODO:AZ: this name is Java-ridiculously long -data SynchronizationTextDocumentClientCapabilities = - SynchronizationTextDocumentClientCapabilities - { -- | Whether text document synchronization supports dynamic registration. - _dynamicRegistration :: Maybe Bool - - -- | The client supports sending will save notifications. - , _willSave :: Maybe Bool - - -- | The client supports sending a will save request and waits for a - -- response providing text edits which will be applied to the document - -- before it is saved. - , _willSaveWaitUntil :: Maybe Bool - - -- | The client supports did save notifications. - , _didSave :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''SynchronizationTextDocumentClientCapabilities - -instance Default SynchronizationTextDocumentClientCapabilities where - def = SynchronizationTextDocumentClientCapabilities def def def def - --- ------------------------------------- - -data ColorProviderClientCapabilities = - ColorProviderClientCapabilities - { -- | Whether colorProvider supports dynamic registration. If this is set to `true` - -- the client supports the new `(ColorProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions)` - -- return value for the corresponding server capability as well. - _dynamicRegistration :: Maybe Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ColorProviderClientCapabilities - - -- ------------------------------------- data TextDocumentClientCapabilities = TextDocumentClientCapabilities - { _synchronization :: Maybe SynchronizationTextDocumentClientCapabilities + { _synchronization :: Maybe TextDocumentSyncClientCapabilities -- | Capabilities specific to the `textDocument/completion` , _completion :: Maybe CompletionClientCapabilities @@ -710,7 +124,7 @@ data TextDocumentClientCapabilities = -- | Capabilities specific to the `textDocument/documentColor` and the -- `textDocument/colorPresentation` request - , _colorProvider :: Maybe ColorProviderClientCapabilities + , _colorProvider :: Maybe DocumentColorClientCapabilities -- | Capabilities specific to the `textDocument/rename` , _rename :: Maybe RenameClientCapabilities @@ -745,54 +159,6 @@ deriveJSON lspOptions ''WindowClientCapabilities instance Default WindowClientCapabilities where def = WindowClientCapabilities def --- --------------------------------------------------------------------- -{- -New in 3.0 - ------------ - -ClientCapabilities - -now define capabilities for dynamic registration, workspace and text document -features the client supports. The experimental can be used to pass experimential -capabilities under development. For future compatibility a ClientCapabilities -object literal can have more properties set than currently defined. Servers -receiving a ClientCapabilities object literal with unknown properties should -ignore these properties. A missing property should be interpreted as an absence -of the capability. If a property is missing that defines sub properties all sub -properties should be interpreted as an absence of the capability. - -Client capabilities got introduced with the version 3.0 of the protocol. They -therefore only describe capabilities that got introduced in 3.x or later. -Capabilities that existed in the 2.x version of the protocol are still mandatory -for clients. Clients cannot opt out of providing them. So even if a client omits -the ClientCapabilities.textDocument.synchronization it is still required that -the client provides text document synchronization (e.g. open, changed and close -notifications). - -interface ClientCapabilities { - /** - * Workspace specific client capabilities. - */ - workspace?: WorkspaceClientCapabilities; - - /** - * Text document specific client capabilities. - */ - textDocument?: TextDocumentClientCapabilities; - - /** - * Experimental client capabilities. - */ - experimental?: any; - - /** - * Window specific client capabilities. - */ - window?: WindowClientCapabilities; -} --} - data ClientCapabilities = ClientCapabilities { _workspace :: Maybe WorkspaceClientCapabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Configuration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Configuration.hs new file mode 100644 index 000000000..29db71f51 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Configuration.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.Haskell.LSP.Types.Configuration where + +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Utils + +-- ------------------------------------- + +data DidChangeConfigurationClientCapabilities = + DidChangeConfigurationClientCapabilities + { _dynamicRegistration :: Maybe Bool -- ^Did change configuration + -- notification supports dynamic + -- registration. + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DidChangeConfigurationClientCapabilities + +data DidChangeConfigurationParams = + DidChangeConfigurationParams + { _settings :: Value -- ^ The actual changed settings + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DidChangeConfigurationParams + +-- --------------------------------------------------------------------- + +data ConfigurationItem = + ConfigurationItem + { _scopeUri :: Maybe Text -- ^ The scope to get the configuration section for. + , _section :: Maybe Text -- ^ The configuration section asked for. + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ConfigurationItem + +data ConfigurationParams = + ConfigurationParams + { _items :: List ConfigurationItem + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''ConfigurationParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs deleted file mode 100644 index fd1113ca4..000000000 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ /dev/null @@ -1,900 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.LSP.Types.DataTypesJSON where - -import qualified Data.Aeson as A -import Data.Aeson.TH -import Data.Aeson.Types -import Data.Bits (testBit) -import Data.Scientific (floatingOrInteger) -import Data.Text (Text) -import qualified Data.Text as T -import Language.Haskell.LSP.Types.ClientCapabilities -import Language.Haskell.LSP.Types.Common -import Language.Haskell.LSP.Types.LspId -import Language.Haskell.LSP.Types.Method -import Language.Haskell.LSP.Types.Progress -import Language.Haskell.LSP.Types.ServerCapabilities -import Language.Haskell.LSP.Types.Uri -import Language.Haskell.LSP.Types.Utils -import Language.Haskell.LSP.Types.WorkspaceEdit -import Language.Haskell.LSP.Types.WorkspaceFolders - --- ===================================================================== --- ACTUAL PROTOCOL ----------------------------------------------------- --- ===================================================================== - --- --------------------------------------------------------------------- --- Initialize Request --- --------------------------------------------------------------------- -{- -Initialize Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#initialize-request - -The initialize request is sent as the first request from the client to the server. - -Request - - method: 'initialize' - params: InitializeParams defined as follows: - -interface InitializeParams { - /** - * The process Id of the parent process that started - * the server. Is null if the process has not been started by another process. - * If the parent process is not alive then the server should exit (see exit notification) its process. - */ - processId: number | null; - - /** - * The rootPath of the workspace. Is null - * if no folder is open. - * - * @deprecated in favour of rootUri. - */ - rootPath?: string | null; - - /** - * The rootUri of the workspace. Is null if no - * folder is open. If both `rootPath` and `rootUri` are set - * `rootUri` wins. - */ - rootUri: DocumentUri | null; - - /** - * User provided initialization options. - */ - initializationOptions?: any; - - /** - * The capabilities provided by the client (editor or tool) - */ - capabilities: ClientCapabilities; - - /** - * The initial trace setting. If omitted trace is disabled ('off'). - */ - trace?: 'off' | 'messages' | 'verbose'; -} --} - -data Trace = TraceOff | TraceMessages | TraceVerbose - deriving (Show, Read, Eq) - -instance A.ToJSON Trace where - toJSON TraceOff = A.String (T.pack "off") - toJSON TraceMessages = A.String (T.pack "messages") - toJSON TraceVerbose = A.String (T.pack "verbose") - -instance A.FromJSON Trace where - parseJSON (A.String s) = case T.unpack s of - "off" -> return TraceOff - "messages" -> return TraceMessages - "verbose" -> return TraceVerbose - _ -> mempty - parseJSON _ = mempty - -data InitializeParams = - InitializeParams { - _processId :: Maybe Int - , _rootPath :: Maybe Text -- ^ Deprecated in favour of _rootUri - , _rootUri :: Maybe Uri - , _initializationOptions :: Maybe A.Value - , _capabilities :: ClientCapabilities - , _trace :: Maybe Trace - -- | The workspace folders configured in the client when the server starts. - -- This property is only available if the client supports workspace folders. - -- It can be `null` if the client supports workspace folders but none are - -- configured. - -- Since LSP 3.6 - -- - -- @since 0.7.0.0 - , _workspaceFolders :: Maybe (List WorkspaceFolder) - , _workDoneToken :: Maybe ProgressToken - } deriving (Show, Read, Eq) - -{-# DEPRECATED _rootPath "Use _rootUri" #-} - -deriveJSON lspOptions ''InitializeParams - --- --------------------------------------------------------------------- --- Initialize Response --- --------------------------------------------------------------------- -{- - - error.data: - -interface InitializeError { - /** - * Indicates whether the client should retry to send the - * initilize request after showing the message provided - * in the ResponseError. - */ - retry: boolean; -- --} -data InitializeError = - InitializeError - { _retry :: Bool - } deriving (Read, Show, Eq) - -deriveJSON lspOptions ''InitializeError - --- --------------------------------------------------------------------- --- | --- Information about the capabilities of a language server --- -data InitializeResponseCapabilities = - InitializeResponseCapabilities { - _capabilities :: ServerCapabilities - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''InitializeResponseCapabilities - --- --------------------------------------------------------------------- - -{- - error.code: - -/** - * Known error codes for an `InitializeError`; - */ -export namespace InitializeError { - /** - * If the protocol version provided by the client can't be handled by the server. - * @deprecated This initialize error got replaced by client capabilities. There is - * no version handshake in version 3.0x - */ - export const unknownProtocolVersion: number = 1; -} - - error.data: - -interface InitializeError { - /** - * Indicates whether the client execute the following retry logic: - * (1) show the message provided by the ResponseError to the user - * (2) user selects retry or cancel - * (3) if user selected retry the initialize method is sent again. - */ - retry: boolean; -} --} - --- --------------------------------------------------------------------- - -{- -New in 3.0 ----------- -Initialized Notification - -The initialized notification is sent from the client to the server after the -client is fully initialized and is able to listen to arbritary requests and -notifications sent from the server. - -Notification: - - method: 'initialized' - params: void - --} - -data InitializedParams = - InitializedParams - { - } deriving (Show, Read, Eq) - -instance A.FromJSON InitializedParams where - parseJSON (A.Object _) = pure InitializedParams - parseJSON _ = mempty - -instance A.ToJSON InitializedParams where - toJSON InitializedParams = A.Object mempty - --- --------------------------------------------------------------------- -{- -Shutdown Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#shutdown-request - -The shutdown request is sent from the client to the server. It asks the server -to shut down, but to not exit (otherwise the response might not be delivered -correctly to the client). There is a separate exit notification that asks the -server to exit. - -Request - - method: 'shutdown' - params: undefined - -Response - - result: undefined - error: code and message set in case an exception happens during shutdown request. - - --} - --- --------------------------------------------------------------------- -{- -Exit Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#exit-notification - -A notification to ask the server to exit its process. - -Notification - - method: 'exit' - --} - --- | --- Notification from the server to actually exit now, after shutdown acked --- -data ExitParams = - ExitParams - { - } deriving (Show, Read, Eq) - -deriveJSON defaultOptions ''ExitParams - --- --------------------------------------------------------------------- -{- -Telemetry Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#telemetry-notification - - New: The telemetry notification is sent from the server to the client to ask - the client to log a telemetry event. - -Notification: - - method: 'telemetry/event' - params: 'any' --} - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -Unregister Capability - -The client/unregisterCapability request is sent from the server to the client to -unregister a previously register capability. - -Request: - - method: 'client/unregisterCapability' - params: UnregistrationParams - -Where UnregistrationParams are defined as follows: - -/** - * General parameters to unregister a capability. - */ -export interface Unregistration { - /** - * The id used to unregister the request or notification. Usually an id - * provided during the register request. - */ - id: string; - - /** - * The method / capability to unregister for. - */ - method: string; -} - -export interface UnregistrationParams { - unregisterations: Unregistration[]; -} --} - -data Unregistration = - Unregistration - { -- | The id used to unregister the request or notification. Usually an id - -- provided during the register request. - _id :: Text - - -- | The method / capability to unregister for. - , _method :: SomeClientMethod - } deriving (Show, Eq) - -deriveJSON lspOptions ''Unregistration - -data UnregistrationParams = - UnregistrationParams - { _unregistrations :: List Unregistration - } deriving (Show, Eq) - -deriveJSON lspOptions ''UnregistrationParams - --- --------------------------------------------------------------------- - --- /** --- * Describe options to be used when registering for file system change events. --- */ --- export interface DidChangeWatchedFilesRegistrationOptions { --- /** --- * The watchers to register. --- */ --- watchers: FileSystemWatcher[]; --- } --- --- export interface FileSystemWatcher { --- /** --- * The glob pattern to watch. --- * --- * Glob patterns can have the following syntax: --- * - `*` to match one or more characters in a path segment --- * - `?` to match on one character in a path segment --- * - `**` to match any number of path segments, including none --- * - `{}` to group conditions (e.g. `**​/*.{ts,js}` matches all TypeScript and JavaScript files) --- * - `[]` to declare a range of characters to match in a path segment (e.g., `example.[0-9]` to match on `example.0`, `example.1`, …) --- * - `[!...]` to negate a range of characters to match in a path segment (e.g., `example.[!0-9]` to match on `example.a`, `example.b`, but not `example.0`) --- */ --- globPattern: string; --- --- /** --- * The kind of events of interest. If omitted it defaults --- * to WatchKind.Create | WatchKind.Change | WatchKind.Delete --- * which is 7. --- */ --- kind?: number; --- } --- --- export namespace WatchKind { --- /** --- * Interested in create events. --- */ --- export const Create = 1; --- --- /** --- * Interested in change events --- */ --- export const Change = 2; --- --- /** --- * Interested in delete events --- */ --- export const Delete = 4; --- } - -data DidChangeWatchedFilesRegistrationOptions = - DidChangeWatchedFilesRegistrationOptions { - _watchers :: List FileSystemWatcher - } deriving (Show, Read, Eq) - -data FileSystemWatcher = - FileSystemWatcher { - _globPattern :: String, - _kind :: Maybe WatchKind - } deriving (Show, Read, Eq) - -data WatchKind = - WatchKind { - -- | Watch for create events - _watchCreate :: Bool, - -- | Watch for change events - _watchChange :: Bool, - -- | Watch for delete events - _watchDelete :: Bool - } deriving (Show, Read, Eq) - -instance A.ToJSON WatchKind where - toJSON wk = A.Number (createNum + changeNum + deleteNum) - where - createNum = if _watchCreate wk then 0x1 else 0x0 - changeNum = if _watchChange wk then 0x2 else 0x0 - deleteNum = if _watchDelete wk then 0x4 else 0x0 - -instance A.FromJSON WatchKind where - parseJSON (A.Number n) - | Right i <- floatingOrInteger n :: Either Double Int - , 0 <= i && i <= 7 = - pure $ WatchKind (testBit i 0x0) (testBit i 0x1) (testBit i 0x2) - | otherwise = mempty - parseJSON _ = mempty - -deriveJSON lspOptions ''FileSystemWatcher -deriveJSON lspOptions ''DidChangeWatchedFilesRegistrationOptions - --- --------------------------------------------------------------------- -{- -DidChangeConfiguration Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#didchangeconfiguration-notification - -A notification sent from the client to the server to signal the change of -configuration settings. - -Notification: - - method: 'workspace/didChangeConfiguration', - params: DidChangeConfigurationParams defined as follows: - -interface DidChangeConfigurationParams { - /** - * The actual changed settings - */ - settings: any; -} --} - -data DidChangeConfigurationParams = - DidChangeConfigurationParams { - _settings :: A.Value - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''DidChangeConfigurationParams - --- --------------------------------------------------------------------- - -{- -Configuration Request (:arrow_right_hook:) -Since version 3.6.0 - -The workspace/configuration request is sent from the server to the client to -fetch configuration settings from the client. The request can fetch n -configuration settings in one roundtrip. The order of the returned configuration -settings correspond to the order of the passed ConfigurationItems (e.g. the -first item in the response is the result for the first configuration item in the -params). - -A ConfigurationItem consist of the configuration section to ask for and an -additional scope URI. The configuration section ask for is defined by the server -and doesn’t necessarily need to correspond to the configuration store used be -the client. So a server might ask for a configuration cpp.formatterOptions but -the client stores the configuration in a XML store layout differently. It is up -to the client to do the necessary conversion. If a scope URI is provided the -client should return the setting scoped to the provided resource. If the client -for example uses EditorConfig to manage its settings the configuration should be -returned for the passed resource URI. If the client can’t provide a -configuration setting for a given scope then null need to be present in the -returned array. - -Request: - -method: ‘workspace/configuration’ -params: ConfigurationParams defined as follows -export interface ConfigurationParams { - items: ConfigurationItem[]; -} - -export interface ConfigurationItem { - /** - * The scope to get the configuration section for. - */ - scopeUri?: string; - - /** - * The configuration section asked for. - */ - section?: string; -} -Response: - -result: any[] -error: code and message set in case an exception happens during the -‘workspace/configuration’ request --} - -data ConfigurationItem = - ConfigurationItem - { _scopeUri :: Maybe Text -- ^ The scope to get the configuration section for. - , _section :: Maybe Text -- ^ The configuration section asked for. - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ConfigurationItem - -data ConfigurationParams = - ConfigurationParams - { _items :: List ConfigurationItem - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ConfigurationParams - --- --------------------------------------------------------------------- -{- -DidChangeWatchedFiles Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#didchangewatchedfiles-notification - -The watched files notification is sent from the client to the server when the -client detects changes to files watched by the language client. - -Notification: - - method: 'workspace/didChangeWatchedFiles' - params: DidChangeWatchedFilesParams defined as follows: - -interface DidChangeWatchedFilesParams { - /** - * The actual file events. - */ - changes: FileEvent[]; -} - -Where FileEvents are described as follows: - -/** - * The file event type. - */ -enum FileChangeType { - /** - * The file got created. - */ - Created = 1, - /** - * The file got changed. - */ - Changed = 2, - /** - * The file got deleted. - */ - Deleted = 3 -} - -/** - * An event describing a file change. - */ -interface FileEvent { - /** - * The file's URI. - */ - uri: string; - /** - * The change type. - */ - type: number; --} -data FileChangeType = FcCreated - | FcChanged - | FcDeleted - deriving (Read,Show,Eq) - -instance A.ToJSON FileChangeType where - toJSON FcCreated = A.Number 1 - toJSON FcChanged = A.Number 2 - toJSON FcDeleted = A.Number 3 - -instance A.FromJSON FileChangeType where - parseJSON (A.Number 1) = pure FcCreated - parseJSON (A.Number 2) = pure FcChanged - parseJSON (A.Number 3) = pure FcDeleted - parseJSON _ = mempty - - --- ------------------------------------- - -data FileEvent = - FileEvent - { _uri :: Uri - , _xtype :: FileChangeType - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''FileEvent - -data DidChangeWatchedFilesParams = - DidChangeWatchedFilesParams - { _changes :: List FileEvent - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''DidChangeWatchedFilesParams - --- --------------------------------------------------------------------- -{- -PublishDiagnostics Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#publishdiagnostics-notification - -Diagnostics notification are sent from the server to the client to signal -results of validation runs. - -Notification - - method: 'textDocument/publishDiagnostics' - params: PublishDiagnosticsParams defined as follows: - -interface PublishDiagnosticsParams { - /** - * The URI for which diagnostic information is reported. - */ - uri: string; - - /** - * An array of diagnostic information items. - */ - diagnostics: Diagnostic[]; -} --} - - --- --------------------------------------------------------------------- -{- -Goto Definition Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#goto-definition-request - -The go to definition request is sent from the client to the server to resolve the definition location of a symbol at a given text document position. - -The result type LocationLink[] got introduced with version 3.14.0 and depends on the corresponding client capability textDocument.definition.linkSupport. - -Client Capability: - -property name (optional): textDocument.definition -property type: DefinitionClientCapabilities defined as follows: -export interface DefinitionClientCapabilities { - /** - * Whether definition supports dynamic registration. - */ - dynamicRegistration?: boolean; - - /** - * The client supports additional metadata in the form of definition links. - * - * @since 3.14.0 - */ - linkSupport?: boolean; -} -Server Capability: - -property name (optional): definitionProvider -property type: boolean | DefinitionOptions where DefinitionOptions is defined as follows: -export interface DefinitionOptions extends WorkDoneProgressOptions { -} -Registration Options: DefinitionRegistrationOptions defined as follows: - -export interface DefinitionRegistrationOptions extends TextDocumentRegistrationOptions, DefinitionOptions { -} -Request: - -method: ‘textDocument/definition’ -params: DefinitionParams defined as follows: -export interface DefinitionParams extends TextDocumentPositionParams, WorkDoneProgressParams, PartialResultParams { -} -Response: - -result: Location | Location[] | LocationLink[] | null -partial result: Location[] | LocationLink[] -error: code and message set in case an exception happens during the definition request. - --} - --- {"jsonrpc":"2.0","id":1,"method":"textDocument/definition","params":{"textDocument":{"uri":"file:///tmp/Foo.hs"},"position":{"line":1,"character":8}}} - --- --------------------------------------------------------------------- -{- -Workspace Symbols Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#workspace-symbols-request - -The workspace symbol request is sent from the client to the server to list -project-wide symbols matching the query string. - -Request - - method: 'workspace/symbol' - params: WorkspaceSymbolParams defined as follows: - -/** - * The parameters of a Workspace Symbol Request. - */ -interface WorkspaceSymbolParams { - /** - * A non-empty query string - */ - query: string; -} - -Response - - result: SymbolInformation[] as defined above. - error: code and message set in case an exception happens during the - workspace symbol request. --} - - -makeExtendingDatatype "WorkspaceSymbolParams" [''WorkDoneProgressParams, ''PartialResultParams] - [("_query", [t| String |])] - -deriveJSON lspOptions ''WorkspaceSymbolParams - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -Execute a command - -The workspace/executeCommand request is sent from the client to the server to -trigger command execution on the server. In most cases the server creates a -WorkspaceEdit structure and applies the changes to the workspace using the -request workspace/applyEdit which is sent from the server to the client. - -Request: - - method: 'workspace/executeCommand' - params: ExecuteCommandParams defined as follows: - -export interface ExecuteCommandParams { - - /** - * The identifier of the actual command handler. - */ - command: string; - /** - * Arguments that the command should be invoked with. - */ - arguments?: any[]; -} - -The arguments are typically specified when a command is returned from the server -to the client. Example requests that return a command are -textDocument/codeAction or textDocument/codeLens. - -Response: - - result: any - error: code and message set in case an exception happens during the request. - -Registration Options: ExecuteCommandRegistrationOptions defined as follows: - -/** - * Execute command registration options. - */ -export interface ExecuteCommandRegistrationOptions { - /** - * The commands to be executed on the server - */ - commands: string[] -} --} - --- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -Applies a WorkspaceEdit - -The workspace/applyEdit request is sent from the server to the client to modify -resource on the client side. - -Request: - - method: 'workspace/applyEdit' - params: ApplyWorkspaceEditParams defined as follows: - -export interface ApplyWorkspaceEditParams { - /** - * The edits to apply. - */ - edit: WorkspaceEdit; -} - -Response: - - result: ApplyWorkspaceEditResponse defined as follows: - -export interface ApplyWorkspaceEditResponse { - /** - * Indicates whether the edit was applied or not. - */ - applied: boolean; -} - - error: code and message set in case an exception happens during the request. - --} -data ApplyWorkspaceEditParams = - ApplyWorkspaceEditParams - { _edit :: WorkspaceEdit - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ApplyWorkspaceEditParams - -data ApplyWorkspaceEditResponseBody = - ApplyWorkspaceEditResponseBody - { _applied :: Bool - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''ApplyWorkspaceEditResponseBody - --- --------------------------------------------------------------------- - -data TraceParams = - TraceParams { - _value :: Text - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''TraceParams - - -data TraceNotification = - TraceNotification { - _params :: TraceParams - } deriving (Show, Read, Eq) - -deriveJSON lspOptions ''TraceNotification - --- --------------------------------------------------------------------- -{- -Cancellation Support - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#cancellation-support - - New: The base protocol now offers support for request cancellation. To - cancel a request, a notification message with the following properties is - sent: - -Notification: - - method: '$/cancelRequest' - params: CancelParams defined as follows: - -interface CancelParams { - /** - * The request id to cancel. - */ - id: number | string; -} - -A request that got canceled still needs to return from the server and send a -response back. It can not be left open / hanging. This is in line with the JSON -RPC protocol that requires that every request sends a response back. In addition -it allows for returning partial results on cancel. --} - -data CancelParams = forall m. - CancelParams - { _id :: LspId m - } - -deriving instance Read CancelParams -deriving instance Show CancelParams -instance Eq CancelParams where - (CancelParams a) == CancelParams b = - case (a,b) of - (IdInt x, IdInt y) -> x == y - (IdString x, IdString y) -> x == y - _ -> False - -deriveJSON lspOptions ''CancelParams - --- --------------------------------------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Initialize.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Initialize.hs new file mode 100644 index 000000000..87213216d --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Initialize.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Language.Haskell.LSP.Types.Initialize where + +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.LSP.Types.ClientCapabilities +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.ServerCapabilities +import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.Utils +import Language.Haskell.LSP.Types.WorkspaceFolders + +data Trace = TraceOff | TraceMessages | TraceVerbose + deriving (Show, Read, Eq) + +instance ToJSON Trace where + toJSON TraceOff = String (T.pack "off") + toJSON TraceMessages = String (T.pack "messages") + toJSON TraceVerbose = String (T.pack "verbose") + +instance FromJSON Trace where + parseJSON (String s) = case T.unpack s of + "off" -> return TraceOff + "messages" -> return TraceMessages + "verbose" -> return TraceVerbose + _ -> mempty + parseJSON _ = mempty + +data ClientInfo = + ClientInfo + { -- | The name of the client as defined by the client. + _name :: Text + -- | The client's version as defined by the client. + , _version :: Maybe Text + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''ClientInfo + +makeExtendingDatatype "InitializeParams" [''WorkDoneProgressParams] + [ ("_processId", [t| Maybe Int|]) + , ("_clientInfo", [t| Maybe ClientInfo |]) + , ("_rootPath", [t| Maybe Text |]) + , ("_rootUri", [t| Maybe Uri |]) + , ("_initializationOptions", [t| Maybe Value |]) + , ("_capabilities", [t| ClientCapabilities |]) + , ("_trace", [t| Maybe Trace |]) + , ("_workspaceFolders", [t| Maybe (List WorkspaceFolder) |]) + ] + +{-# DEPRECATED _rootPath "Use _rootUri" #-} + +deriveJSON lspOptions ''InitializeParams + +data InitializeError = + InitializeError + { _retry :: Bool + } deriving (Read, Show, Eq) + +deriveJSON lspOptions ''InitializeError + +data ServerInfo = + ServerInfo + { -- | The name of the server as defined by the server. + _name :: Text + -- | The server's version as defined by the server. + , _version :: Maybe Text + } deriving (Show, Read, Eq) +deriveJSON lspOptions ''ServerInfo + +data InitializeResult = + InitializeResult + { -- | The capabilities the language server provides. + _capabilities :: ServerCapabilities + -- | Information about the server. + -- Since LSP 3.15.0 + , _serverInfo :: Maybe ServerInfo + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''InitializeResult + +-- --------------------------------------------------------------------- + +data InitializedParams = + InitializedParams + { + } deriving (Show, Read, Eq) + +instance FromJSON InitializedParams where + parseJSON (Object _) = pure InitializedParams + parseJSON _ = mempty + +instance ToJSON InitializedParams where + toJSON InitializedParams = Object mempty + diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index b45d979bf..80becd956 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -8,15 +8,16 @@ module Language.Haskell.LSP.Types.Lens where +import Language.Haskell.LSP.Types.Cancellation import Language.Haskell.LSP.Types.ClientCapabilities import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens +import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion -import Language.Haskell.LSP.Types.DataTypesJSON +import Language.Haskell.LSP.Types.Configuration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic -import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink @@ -24,6 +25,7 @@ import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation +import Language.Haskell.LSP.Types.Initialize import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Registration @@ -36,8 +38,10 @@ import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Window +import Language.Haskell.LSP.Types.WatchedFiles import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders +import Language.Haskell.LSP.Types.WorkspaceSymbol import Language.Haskell.LSP.Types.Message import Control.Lens.TH @@ -46,12 +50,9 @@ import Control.Lens.TH -- client capabilities makeFieldsNoPrefix ''WorkspaceEditClientCapabilities makeFieldsNoPrefix ''DidChangeConfigurationClientCapabilities -makeFieldsNoPrefix ''DidChangeWatchedFilesClientCapabilities -makeFieldsNoPrefix ''WorkspaceSymbolKindClientCapabilities -makeFieldsNoPrefix ''WorkspaceSymbolClientCapabilities makeFieldsNoPrefix ''ExecuteCommandClientCapabilities makeFieldsNoPrefix ''WorkspaceClientCapabilities -makeFieldsNoPrefix ''SynchronizationTextDocumentClientCapabilities +makeFieldsNoPrefix ''TextDocumentSyncClientCapabilities makeFieldsNoPrefix ''CompletionItemTagsClientCapabilities makeFieldsNoPrefix ''CompletionItemClientCapabilities makeFieldsNoPrefix ''CompletionItemKindClientCapabilities @@ -64,7 +65,6 @@ makeFieldsNoPrefix ''ReferencesClientCapabilities makeFieldsNoPrefix ''DefinitionClientCapabilities makeFieldsNoPrefix ''TypeDefinitionClientCapabilities makeFieldsNoPrefix ''ImplementationClientCapabilities -makeFieldsNoPrefix ''ColorProviderClientCapabilities makeFieldsNoPrefix ''PublishDiagnosticsClientCapabilities makeFieldsNoPrefix ''PublishDiagnosticsTagsClientCapabilities makeFieldsNoPrefix ''TextDocumentClientCapabilities @@ -72,8 +72,6 @@ makeFieldsNoPrefix ''ClientCapabilities -- --------------------------------------------------------------------- -makeFieldsNoPrefix ''InitializeParams -makeFieldsNoPrefix ''InitializeError makeFieldsNoPrefix ''CompletionOptions makeFieldsNoPrefix ''SignatureHelpOptions makeFieldsNoPrefix ''ExecuteCommandOptions @@ -82,12 +80,8 @@ makeFieldsNoPrefix ''TextDocumentSyncOptions makeFieldsNoPrefix ''WorkspaceServerCapabilities makeFieldsNoPrefix ''WorkspaceFoldersServerCapabilities makeFieldsNoPrefix ''ServerCapabilities -makeFieldsNoPrefix ''InitializeResponseCapabilities makeFieldsNoPrefix ''Registration makeFieldsNoPrefix ''RegistrationParams -makeFieldsNoPrefix ''DidChangeWatchedFilesRegistrationOptions -makeFieldsNoPrefix ''FileSystemWatcher -makeFieldsNoPrefix ''WatchKind makeFieldsNoPrefix ''TextDocumentRegistrationOptions makeFieldsNoPrefix ''Unregistration makeFieldsNoPrefix ''UnregistrationParams @@ -102,8 +96,6 @@ makeFieldsNoPrefix ''WillSaveTextDocumentParams makeFieldsNoPrefix ''DidSaveTextDocumentParams makeFieldsNoPrefix ''TextDocumentSaveRegistrationOptions makeFieldsNoPrefix ''DidCloseTextDocumentParams -makeFieldsNoPrefix ''FileEvent -makeFieldsNoPrefix ''DidChangeWatchedFilesParams makeFieldsNoPrefix ''PublishDiagnosticsParams makeFieldsNoPrefix ''LanguageString makeFieldsNoPrefix ''ParameterInformation @@ -112,16 +104,36 @@ makeFieldsNoPrefix ''SignatureHelp makeFieldsNoPrefix ''SignatureHelpRegistrationOptions makeFieldsNoPrefix ''ReferenceContext makeFieldsNoPrefix ''ReferenceParams -makeFieldsNoPrefix ''WorkspaceSymbolParams makeFieldsNoPrefix ''ExecuteCommandParams makeFieldsNoPrefix ''ExecuteCommandRegistrationOptions makeFieldsNoPrefix ''ApplyWorkspaceEditParams makeFieldsNoPrefix ''ApplyWorkspaceEditResponseBody -makeFieldsNoPrefix ''TraceParams -makeFieldsNoPrefix ''TraceNotification -- --------------------------------------------------------------------- +-- Initialize +makeFieldsNoPrefix ''InitializeParams +makeFieldsNoPrefix ''InitializeError +makeFieldsNoPrefix ''InitializeResult +makeFieldsNoPrefix ''ClientInfo +makeFieldsNoPrefix ''ServerInfo +makeFieldsNoPrefix ''InitializedParams + +-- Watched files +makeFieldsNoPrefix ''DidChangeWatchedFilesClientCapabilities +makeFieldsNoPrefix ''DidChangeWatchedFilesRegistrationOptions +makeFieldsNoPrefix ''FileSystemWatcher +makeFieldsNoPrefix ''WatchKind +makeFieldsNoPrefix ''FileEvent +makeFieldsNoPrefix ''DidChangeWatchedFilesParams + +-- Workspace symbols +makeFieldsNoPrefix ''WorkspaceSymbolKindClientCapabilities +makeFieldsNoPrefix ''WorkspaceSymbolClientCapabilities +makeFieldsNoPrefix ''WorkspaceSymbolOptions +makeFieldsNoPrefix ''WorkspaceSymbolRegistrationOptions +makeFieldsNoPrefix ''WorkspaceSymbolParams + -- Location makeFieldsNoPrefix ''Position makeFieldsNoPrefix ''Range diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 2a9e930f9..611c65f8e 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -18,11 +18,12 @@ module Language.Haskell.LSP.Types.Message where -import Language.Haskell.LSP.Types.DataTypesJSON +import Language.Haskell.LSP.Types.Cancellation import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Configuration import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition @@ -35,6 +36,7 @@ import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation +import Language.Haskell.LSP.Types.Initialize import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.LspId import Language.Haskell.LSP.Types.Method @@ -48,8 +50,10 @@ import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils import Language.Haskell.LSP.Types.Window +import Language.Haskell.LSP.Types.WatchedFiles import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders +import Language.Haskell.LSP.Types.WorkspaceSymbol import qualified Data.HashMap.Strict as HM import Data.Kind @@ -72,7 +76,7 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams Initialize = InitializeParams MessageParams Initialized = Maybe InitializedParams MessageParams Shutdown = Maybe Value - MessageParams Exit = Maybe ExitParams + MessageParams Exit = Empty -- Workspace MessageParams WorkspaceDidChangeWorkspaceFolders = DidChangeWorkspaceFoldersParams MessageParams WorkspaceDidChangeConfiguration = DidChangeConfigurationParams @@ -152,7 +156,7 @@ type family ResponseParams (m :: Method p Request) :: Type where -- Client -- General - ResponseParams Initialize = InitializeResponseCapabilities + ResponseParams Initialize = InitializeResult ResponseParams Shutdown = Empty -- Workspace ResponseParams WorkspaceSymbol = List SymbolInformation @@ -273,42 +277,6 @@ instance FromJSON (CustomMessage p Notification) where -- --------------------------------------------------------------------- -- Response Message -- --------------------------------------------------------------------- -{- -interface ResponseError { - /** - * A number indicating the error type that occurred. - */ - code: number; - - /** - * A string providing a short description of the error. - */ - message: string; - - /** - * A Primitive or Structured value that contains additional - * information about the error. Can be omitted. - */ - data?: D; -} - -export namespace ErrorCodes { - // Defined by JSON RPC - export const ParseError: number = -32700; - export const InvalidRequest: number = -32600; - export const MethodNotFound: number = -32601; - export const InvalidParams: number = -32602; - export const InternalError: number = -32603; - export const serverErrorStart: number = -32099; - export const serverErrorEnd: number = -32000; - export const ServerNotInitialized: number = -32002; - export const UnknownErrorCode: number = -32001; - - // Defined by the protocol. - export const RequestCancelled: number = -32800; - export const ContentModified: number = -32801; -} --} data ErrorCode = ParseError | InvalidRequest @@ -353,28 +321,6 @@ instance FromJSON ErrorCode where -- ------------------------------------- -{- - https://microsoft.github.io/language-server-protocol/specification#responseMessage - - interface ResponseError { - /** - * A number indicating the error type that occurred. - */ - code: number; - - /** - * A string providing a short description of the error. - */ - message: string; - - /** - * A primitive or structured value that contains additional - * information about the error. Can be omitted. - */ - data?: string | number | boolean | array | object | null; - } --} - data ResponseError = ResponseError { _code :: ErrorCode diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index 9ca5e9c4a..76fccd3a0 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -16,6 +16,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -Werror=incomplete-patterns #-} @@ -34,12 +35,12 @@ import Language.Haskell.LSP.Types.CodeLens import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Completion -import Language.Haskell.LSP.Types.DataTypesJSON import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover @@ -48,64 +49,23 @@ import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SignatureHelp -import Language.Haskell.LSP.Types.DocumentSymbol +import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition import Language.Haskell.LSP.Types.Utils +import Language.Haskell.LSP.Types.WatchedFiles +import Language.Haskell.LSP.Types.WorkspaceSymbol -- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -Register Capability - -The client/registerCapability request is sent from the server to the client to -register for a new capability on the client side. Not all clients need to -support dynamic capability registration. A client opts in via the -ClientCapabilities.dynamicRegistration property. - -Request: - - method: 'client/registerCapability' - params: RegistrationParams - -Where RegistrationParams are defined as follows: - -/** - * General paramters to to regsiter for a capability. - */ -export interface Registration { - /** - * The id used to register the request. The id can be used to deregister - * the request again. - */ - id: string; - - /** - * The method / capability to register for. - */ - method: string; - - /** - * Options necessary for the registration. - */ - registerOptions?: any; -} - -export interface RegistrationParams { - registrations: Registration[]; -} --} - +-- | Matches up the registration options for a specific method type family RegistrationOptions (m :: Method FromClient t) :: Type where -- Workspace RegistrationOptions WorkspaceDidChangeWorkspaceFolders = Empty RegistrationOptions WorkspaceDidChangeConfiguration = Empty RegistrationOptions WorkspaceDidChangeWatchedFiles = DidChangeWatchedFilesRegistrationOptions - RegistrationOptions WorkspaceSymbol = Empty + RegistrationOptions WorkspaceSymbol = WorkspaceSymbolRegistrationOptions RegistrationOptions WorkspaceExecuteCommand = ExecuteCommandRegistrationOptions -- Text synchronisation @@ -136,8 +96,7 @@ type family RegistrationOptions (m :: Method FromClient t) :: Type where RegistrationOptions TextDocumentOnTypeFormatting = DocumentOnTypeFormattingRegistrationOptions RegistrationOptions TextDocumentRename = RenameRegistrationOptions RegistrationOptions TextDocumentFoldingRange = FoldingRangeRegistrationOptions - -- TODO: Add me once textDocument/selectionRange is implemented - -- RegistrationOptions TextDocumentSelectionRange = SelectionRangeRegistrationOptions + RegistrationOptions TextDocumentSelectionRange = SelectionRangeRegistrationOptions RegistrationOptions m = Void data Registration (m :: Method FromClient t) = @@ -190,3 +149,28 @@ data RegistrationParams = deriving (Show, Eq) deriveJSON lspOptions ''RegistrationParams + + +-- --------------------------------------------------------------------- + +-- | General parameters to unregister a capability. +data Unregistration = + Unregistration + { -- | The id used to unregister the request or notification. Usually an id + -- provided during the register request. + _id :: Text + -- | The method / capability to unregister for. + , _method :: SomeClientMethod + } deriving (Show, Eq) + +deriveJSON lspOptions ''Unregistration + +data UnregistrationParams = + UnregistrationParams + { -- | This should correctly be named @unregistrations@. However changing this + -- is a breaking change and needs to wait until we deliver a 4.x version + -- of the specification. + _unregistrations :: List Unregistration + } deriving (Show, Eq) + +deriveJSON lspOptions ''UnregistrationParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs index a77010d33..22cc02699 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs @@ -5,6 +5,7 @@ module Language.Haskell.LSP.Types.TextDocument where import Data.Aeson import Data.Aeson.TH +import Data.Default import Data.Text ( Text ) import Language.Haskell.LSP.Types.Common @@ -118,6 +119,31 @@ deriveJSON lspOptions ''TextDocumentPositionParams -- Text document synchronisation + +data TextDocumentSyncClientCapabilities = + TextDocumentSyncClientCapabilities + { -- | Whether text document synchronization supports dynamic registration. + _dynamicRegistration :: Maybe Bool + + -- | The client supports sending will save notifications. + , _willSave :: Maybe Bool + + -- | The client supports sending a will save request and waits for a + -- response providing text edits which will be applied to the document + -- before it is saved. + , _willSaveWaitUntil :: Maybe Bool + + -- | The client supports did save notifications. + , _didSave :: Maybe Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''TextDocumentSyncClientCapabilities + +instance Default TextDocumentSyncClientCapabilities where + def = TextDocumentSyncClientCapabilities def def def def + +-- ------------------------------------- + -- | Defines how the host (editor) should sync document changes to the language server. data TextDocumentSyncKind = -- | Documents should not be synced at all. diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WatchedFiles.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WatchedFiles.hs new file mode 100644 index 000000000..5b2eabbf2 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WatchedFiles.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Language.Haskell.LSP.Types.WatchedFiles where + +import Data.Aeson +import Data.Aeson.TH +import Data.Bits +import Data.Scientific +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.Uri +import Language.Haskell.LSP.Types.Utils + +-- ------------------------------------- + +data DidChangeWatchedFilesClientCapabilities = DidChangeWatchedFilesClientCapabilities + { -- | Did change watched files notification supports dynamic + -- registration. + _dynamicRegistration :: Maybe Bool + } + deriving (Show, Read, Eq) +deriveJSON lspOptions ''DidChangeWatchedFilesClientCapabilities + +-- | Describe options to be used when registering for file system change events. +data DidChangeWatchedFilesRegistrationOptions = + DidChangeWatchedFilesRegistrationOptions + { -- | The watchers to register. + _watchers :: List FileSystemWatcher + } deriving (Show, Read, Eq) + +data FileSystemWatcher = + FileSystemWatcher + { -- | The glob pattern to watch. + -- Glob patterns can have the following syntax: + -- - @*@ to match one or more characters in a path segment + -- - @?@ to match on one character in a path segment + -- - @**@ to match any number of path segments, including none + -- - @{}@ to group conditions (e.g. @**​/*.{ts,js}@ matches all TypeScript and JavaScript files) + -- - @[]@ to declare a range of characters to match in a path segment (e.g., @example.[0-9]@ to match on @example.0@, @example.1@, …) + -- - @[!...]@ to negate a range of characters to match in a path segment (e.g., @example.[!0-9]@ to match on @example.a@, @example.b@, but not @example.0@) + _globPattern :: String, + -- | The kind of events of interest. If omitted it defaults + -- to WatchKind.Create | WatchKind.Change | WatchKind.Delete + -- which is 7. + _kind :: Maybe WatchKind + } deriving (Show, Read, Eq) + +data WatchKind = + WatchKind { + -- | Watch for create events + _watchCreate :: Bool, + -- | Watch for change events + _watchChange :: Bool, + -- | Watch for delete events + _watchDelete :: Bool + } deriving (Show, Read, Eq) + +instance ToJSON WatchKind where + toJSON wk = Number (createNum + changeNum + deleteNum) + where + createNum = if _watchCreate wk then 0x1 else 0x0 + changeNum = if _watchChange wk then 0x2 else 0x0 + deleteNum = if _watchDelete wk then 0x4 else 0x0 + +instance FromJSON WatchKind where + parseJSON (Number n) + | Right i <- floatingOrInteger n :: Either Double Int + , 0 <= i && i <= 7 = + pure $ WatchKind (testBit i 0x0) (testBit i 0x1) (testBit i 0x2) + | otherwise = mempty + parseJSON _ = mempty + +deriveJSON lspOptions ''DidChangeWatchedFilesRegistrationOptions +deriveJSON lspOptions ''FileSystemWatcher + +-- | The file event type. +data FileChangeType = FcCreated -- ^ The file got created. + | FcChanged -- ^ The file got changed. + | FcDeleted -- ^ The file got deleted. + deriving (Read,Show,Eq) + +instance ToJSON FileChangeType where + toJSON FcCreated = Number 1 + toJSON FcChanged = Number 2 + toJSON FcDeleted = Number 3 + +instance FromJSON FileChangeType where + parseJSON (Number 1) = pure FcCreated + parseJSON (Number 2) = pure FcChanged + parseJSON (Number 3) = pure FcDeleted + parseJSON _ = mempty + + +-- ------------------------------------- + +-- | An event describing a file change. +data FileEvent = + FileEvent + { -- | The file's URI. + _uri :: Uri + -- | The change type. + , _xtype :: FileChangeType + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''FileEvent + +data DidChangeWatchedFilesParams = + DidChangeWatchedFilesParams + { -- | The actual file events. + _changes :: List FileEvent + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''DidChangeWatchedFilesParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs index 3685d5632..8565f0985 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Types.WorkspaceEdit where +import Data.Aeson import Data.Aeson.TH import qualified Data.HashMap.Strict as H -- For <= 8.2.2 @@ -17,29 +19,6 @@ import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- -{- -TextEdit - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#textedit - -A textual edit applicable to a text document. - -interface TextEdit { - /** - * The range of the text document to be manipulated. To insert - * text into a document create a range where start === end. - */ - range: Range; - - /** - * The string to be inserted. For delete operations use an - * empty string. - */ - newText: string; -} - - --} data TextEdit = TextEdit @@ -51,31 +30,6 @@ deriveJSON lspOptions ''TextEdit -- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -TextDocumentEdit -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#new-textdocumentedit - -If multiple TextEdits are applied to a text document, all text edits describe -changes made to the initial document version. Execution wise text edits should -applied from the bottom to the top of the text document. Overlapping text edits -are not supported. - -export interface TextDocumentEdit { - /** - * The text document to change. - */ - textDocument: VersionedTextDocumentIdentifier; - - /** - * The edits to be applied. - */ - edits: TextEdit[]; -} - --} data TextDocumentEdit = TextDocumentEdit @@ -86,34 +40,6 @@ data TextDocumentEdit = deriveJSON lspOptions ''TextDocumentEdit -- --------------------------------------------------------------------- -{- -Changed in 3.0 --------------- - -WorkspaceEdit - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#workspaceedit - - -Changed A workspace edit represents changes to many resources managed in the -workspace. The edit should either provide changes or documentChanges. If -documentChanges are present they are preferred over changes if the client can -handle versioned document edits. - -export interface WorkspaceEdit { - /** - * Holds changes to existing resources. - */ - changes?: { [uri: string]: TextEdit[]; }; - - /** - * An array of `TextDocumentEdit`s to express changes to specific a specific - * version of a text document. Whether a client supports versioned document - * edits is expressed via `WorkspaceClientCapabilities.versionedWorkspaceEdit`. - */ - documentChanges?: TextDocumentEdit[]; -} --} type WorkspaceEditMap = H.HashMap Uri (List TextEdit) @@ -134,6 +60,86 @@ instance Semigroup WorkspaceEdit where deriveJSON lspOptions ''WorkspaceEdit +-- ------------------------------------- + +data ResourceOperationKind + = ResourceOperationCreate -- ^ Supports creating new files and folders. + | ResourceOperationRename -- ^ Supports renaming existing files and folders. + | ResourceOperationDelete -- ^ Supports deleting existing files and folders. + deriving (Read, Show, Eq) + +instance ToJSON ResourceOperationKind where + toJSON ResourceOperationCreate = String "create" + toJSON ResourceOperationRename = String "rename" + toJSON ResourceOperationDelete = String "delete" + +instance FromJSON ResourceOperationKind where + parseJSON (String "create") = pure ResourceOperationCreate + parseJSON (String "rename") = pure ResourceOperationRename + parseJSON (String "delete") = pure ResourceOperationDelete + parseJSON _ = mempty + +data FailureHandlingKind + = FailureHandlingAbort -- ^ Applying the workspace change is simply aborted if one of the changes provided fails. All operations executed before the failing operation stay executed. + | FailureHandlingTransactional -- ^ All operations are executed transactional. That means they either all succeed or no changes at all are applied to the workspace. + | FailureHandlingTextOnlyTransactional -- ^ If the workspace edit contains only textual file changes they are executed transactional. If resource changes (create, rename or delete file) are part of the change the failure handling strategy is abort. + | FailureHandlingUndo -- ^ The client tries to undo the operations already executed. But there is no guarantee that this is succeeding. + deriving (Read, Show, Eq) + +instance ToJSON FailureHandlingKind where + toJSON FailureHandlingAbort = String "abort" + toJSON FailureHandlingTransactional = String "transactional" + toJSON FailureHandlingTextOnlyTransactional = String "textOnlyTransactional" + toJSON FailureHandlingUndo = String "undo" + +instance FromJSON FailureHandlingKind where + parseJSON (String "abort") = pure FailureHandlingAbort + parseJSON (String "transactional") = pure FailureHandlingTransactional + parseJSON (String "textOnlyTransactional") = pure FailureHandlingTextOnlyTransactional + parseJSON (String "undo") = pure FailureHandlingUndo + parseJSON _ = mempty + +data WorkspaceEditClientCapabilities = + WorkspaceEditClientCapabilities + { _documentChanges :: Maybe Bool -- ^The client supports versioned document + -- changes in 'WorkspaceEdit's + -- | The resource operations the client supports. Clients should at least + -- support @create@, @rename@ and @delete@ files and folders. + , _resourceOperations :: Maybe (List ResourceOperationKind) + -- | The failure handling strategy of a client if applying the workspace edit + -- fails. + , _failureHandling :: Maybe FailureHandlingKind + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''WorkspaceEditClientCapabilities + +-- --------------------------------------------------------------------- + +data ApplyWorkspaceEditParams = + ApplyWorkspaceEditParams + { -- | An optional label of the workspace edit. This label is + -- presented in the user interface for example on an undo + -- stack to undo the workspace edit. + _label :: Maybe Text + -- | The edits to apply + , _edit :: WorkspaceEdit + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ApplyWorkspaceEditParams + +data ApplyWorkspaceEditResponseBody = + ApplyWorkspaceEditResponseBody + { -- | Indicates whether the edit was applied or not. + _applied :: Bool + -- | An optional textual description for why the edit was not applied. + -- This may be used may be used by the server for diagnostic + -- logging or to provide a suitable error for a request that + -- triggered the edit. + , _failureReason :: Maybe Text + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''ApplyWorkspaceEditResponseBody + -- --------------------------------------------------------------------- -- | Applies a 'TextEdit' to some 'Text'. diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceSymbol.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceSymbol.hs new file mode 100644 index 000000000..eae512d37 --- /dev/null +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceSymbol.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Language.Haskell.LSP.Types.WorkspaceSymbol where + +import Data.Aeson.TH +import Data.Default +import Language.Haskell.LSP.Types.Common +import Language.Haskell.LSP.Types.DocumentSymbol +import Language.Haskell.LSP.Types.Progress +import Language.Haskell.LSP.Types.Utils + +data WorkspaceSymbolKindClientCapabilities = + WorkspaceSymbolKindClientCapabilities + { -- | The symbol kind values the client supports. When this + -- property exists the client also guarantees that it will + -- handle values outside its set gracefully and falls back + -- to a default value when unknown. + -- + -- If this property is not present the client only supports + -- the symbol kinds from `File` to `Array` as defined in + -- the initial version of the protocol. + _valueSet :: Maybe (List SymbolKind) + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''WorkspaceSymbolKindClientCapabilities + +instance Default WorkspaceSymbolKindClientCapabilities where + def = WorkspaceSymbolKindClientCapabilities (Just $ List allKinds) + where allKinds = [ SkFile + , SkModule + , SkNamespace + , SkPackage + , SkClass + , SkMethod + , SkProperty + , SkField + , SkConstructor + , SkEnum + , SkInterface + , SkFunction + , SkVariable + , SkConstant + , SkString + , SkNumber + , SkBoolean + , SkArray + ] + +data WorkspaceSymbolClientCapabilities = + WorkspaceSymbolClientCapabilities + { _dynamicRegistration :: Maybe Bool -- ^Symbol request supports dynamic + -- registration. + , _symbolKind :: Maybe WorkspaceSymbolKindClientCapabilities -- ^ Specific capabilities for the `SymbolKind`. + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''WorkspaceSymbolClientCapabilities + +-- ------------------------------------- + +makeExtendingDatatype "WorkspaceSymbolOptions" [''WorkDoneProgressOptions] [] +deriveJSON lspOptions ''WorkspaceSymbolOptions + +makeExtendingDatatype "WorkspaceSymbolRegistrationOptions" + [''WorkspaceSymbolOptions] [] +deriveJSON lspOptions ''WorkspaceSymbolRegistrationOptions + +-- ------------------------------------- + +makeExtendingDatatype "WorkspaceSymbolParams" + [ ''WorkDoneProgressParams + , ''PartialResultParams + ] + [("_query", [t| String |])] + +deriveJSON lspOptions ''WorkspaceSymbolParams From 14758253705de86897635ef6a3b7adda9de744b9 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 18 Aug 2020 01:34:52 +0100 Subject: [PATCH 25/63] Remove inline comments containg the spec These got outdated very quickly and just became one more thing to have to maintain --- .../Language/Haskell/LSP/Types/Diagnostic.hs | 109 +--------------- .../Haskell/LSP/Types/DocumentFilter.hs | 45 ++----- .../Language/Haskell/LSP/Types/Location.hs | 67 +--------- .../Haskell/LSP/Types/MarkupContent.hs | 61 --------- .../Language/Haskell/LSP/Types/Progress.hs | 122 +----------------- .../Haskell/LSP/Types/TextDocument.hs | 65 ---------- .../src/Language/Haskell/LSP/Types/Window.hs | 120 +---------------- .../Haskell/LSP/Types/WorkspaceFolders.hs | 86 ------------ 8 files changed, 26 insertions(+), 649 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs index 3897df4d7..1fd4890de 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs @@ -16,28 +16,7 @@ import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- -{- -The protocol currently supports the following diagnostic severities: - -enum DiagnosticSeverity { - /** - * Reports an error. - */ - Error = 1, - /** - * Reports a warning. - */ - Warning = 2, - /** - * Reports an information. - */ - Information = 3, - /** - * Reports a hint. - */ - Hint = 4 -} --} + data DiagnosticSeverity = DsError -- ^ Error = 1, | DsWarning -- ^ Warning = 2, @@ -60,25 +39,6 @@ instance A.FromJSON DiagnosticSeverity where parseJSON (A.Number 4) = pure DsHint parseJSON _ = mempty -{- -The diagnostic tags. - -export namespace DiagnosticTag { - /** - * Unused or unnecessary code. - * - * Clients are allowed to render diagnostics with this tag faded out instead of having - * an error squiggle. - */ - export const Unnecessary: 1; - /** - * Deprecated or obsolete code. - * - * Clients are allowed to rendered diagnostics with this tag strike through. - */ - export const Deprecated: 2; -} --} data DiagnosticTag -- | Unused or unnecessary code. -- @@ -104,23 +64,6 @@ instance A.FromJSON DiagnosticTag where parseJSON _ = mempty -- --------------------------------------------------------------------- -{- -Represents a related message and source code location for a diagnostic. This should be -used to point to code locations that cause or related to a diagnostics, e.g when duplicating -a symbol in a scope. - -export interface DiagnosticRelatedInformation { - /** - * The location of this related diagnostic information. - */ - location: Location; - - /** - * The message of this related diagnostic information. - */ - message: string; -} --} data DiagnosticRelatedInformation = DiagnosticRelatedInformation @@ -133,56 +76,6 @@ instance NFData DiagnosticRelatedInformation deriveJSON lspOptions ''DiagnosticRelatedInformation -- --------------------------------------------------------------------- -{- -Diagnostic - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#diagnostic - -Represents a diagnostic, such as a compiler error or warning. Diagnostic objects -are only valid in the scope of a resource. - -interface Diagnostic { - /** - * The range at which the message applies. - */ - range: Range; - - /** - * The diagnostic's severity. Can be omitted. If omitted it is up to the - * client to interpret diagnostics as error, warning, info or hint. - */ - severity?: number; - - /** - * The diagnostic's code. Can be omitted. - */ - code?: number | string; - - /** - * A human-readable string describing the source of this - * diagnostic, e.g. 'typescript' or 'super lint'. - */ - source?: string; - - /** - * The diagnostic's message. - */ - message: string; - - /** - * Additional metadata about the diagnostic. - * - * @since 3.15.0 - */ - tags?: DiagnosticTag[]; - - /** - * An array of related diagnostic information, e.g. when symbol-names within - * a scope collide all definitions can be marked via this property. - */ - relatedInformation?: DiagnosticRelatedInformation[]; -} --} type DiagnosticSource = Text data Diagnostic = diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs index bf46ddb60..223a7e654 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs @@ -7,42 +7,23 @@ import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- -{- -New in 3.0 ----------- - -DocumentFilter -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#new-documentfilter - -A document filter denotes a document through properties like language, schema or -pattern. Examples are a filter that applies to TypeScript files on disk or a -filter the applies to JSON files with name package.json: - - { language: 'typescript', scheme: 'file' } - { language: 'json', pattern: '**/package.json' } -export interface DocumentFilter { - /** - * A language id, like `typescript`. - */ - language?: string; - - /** - * A Uri [scheme](#Uri.scheme), like `file` or `untitled`. - */ - scheme?: string; - - /** - * A glob pattern, like `*.{ts,js}`. - */ - pattern?: string; -} --} data DocumentFilter = DocumentFilter - { _language :: Maybe Text + { -- | A language id, like `typescript`. + _language :: Maybe Text + -- | A Uri scheme, like @file@ or @untitled@. , _scheme :: Maybe Text - , _pattern :: Maybe Text + , -- | A glob pattern, like `*.{ts,js}`. + -- + -- Glob patterns can have the following syntax: + -- - @*@ to match one or more characters in a path segment + -- - @?@ to match on one character in a path segment + -- - @**@ to match any number of path segments, including none + -- - @{}@ to group conditions (e.g. @**​/*.{ts,js}@ matches all TypeScript and JavaScript files) + -- - @[]@ to declare a range of characters to match in a path segment (e.g., @example.[0-9]@ to match on @example.0@, @example.1@, …) + -- - @[!...]@ to negate a range of characters to match in a path segment (e.g., @example.[!0-9]@ to match on @example.a@, @example.b@, but not @example.0@) + _pattern :: Maybe Text } deriving (Show, Read, Eq) deriveJSON lspOptions ''DocumentFilter diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs index eb4b1f4aa..880d3d5e2 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Location.hs @@ -10,37 +10,13 @@ import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- -{- -The current protocol is talored for textual documents which content can be -represented as a string. There is currently no support for binary documents. -Positions inside a document (see Position definition below) are expressed as a -zero-based line and character offset. To ensure that both client and server -split the string into the same line representation the protocol specs the -following end of line sequences: '\n', '\r\n' and '\r'. - -export const EOL: string[] = ['\n', '\r\n', '\r']; --} -{- -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#position - -Position in a text document expressed as zero-based line and character offset. A -position is between two characters like an 'insert' cursor in a editor. - -interface Position { - /** - * Line position in a document (zero-based). - */ - line: number; - - /** - * Character offset on a line in a document (zero-based). - */ - character: number; -} --} data Position = Position - { _line :: Int + { -- | Line position in a document (zero-based). + _line :: Int + -- | Character offset on a line in a document (zero-based). Assuming that + -- the line is represented as a string, the @character@ value represents the + -- gap between the @character@ and @character + 1@. , _character :: Int } deriving (Show, Read, Eq, Ord, Generic) @@ -48,46 +24,17 @@ instance NFData Position deriveJSON lspOptions ''Position -- --------------------------------------------------------------------- -{- -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#range - -A range in a text document expressed as (zero-based) start and end positions. A -range is comparable to a selection in an editor. Therefore the end position is -exclusive. - -interface Range { - /** - * The range's start position. - */ - start: Position; - - /** - * The range's end position. - */ - end: Position; -} --} data Range = Range - { _start :: Position - , _end :: Position + { _start :: Position -- ^ The range's start position. + , _end :: Position -- ^ The range's end position. } deriving (Show, Read, Eq, Ord, Generic) instance NFData Range deriveJSON lspOptions ''Range -- --------------------------------------------------------------------- -{- -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#location - -Represents a location inside a resource, such as a line inside a text file. - -interface Location { - uri: string; - range: Range; -} --} data Location = Location diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs index f50fc4e90..dc7de0e63 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs @@ -16,28 +16,6 @@ import Data.Monoid ((<>)) import Data.Text (Text) import Language.Haskell.LSP.Types.Utils -{- -/** - * Describes the content type that a client supports in various - * result literals like `Hover`, `ParameterInfo` or `CompletionItem`. - * - * Please note that `MarkupKinds` must not start with a `$`. This kinds - * are reserved for internal usage. - */ -export namespace MarkupKind { - /** - * Plain text is supported as a content format - */ - export const PlainText: 'plaintext' = 'plaintext'; - - /** - * Markdown is supported as a content format - */ - export const Markdown: 'markdown' = 'markdown'; -} -export type MarkupKind = 'plaintext' | 'markdown'; --} - -- | Describes the content type that a client supports in various -- result literals like `Hover`, `ParameterInfo` or `CompletionItem`. data MarkupKind = MkPlainText -- ^ Plain text is supported as a content format @@ -53,45 +31,6 @@ instance FromJSON MarkupKind where parseJSON (String "markdown") = pure MkMarkdown parseJSON _ = mempty - -{- -/** - * A `MarkupContent` literal represents a string value which content is interpreted base on its - * kind flag. Currently the protocol supports `plaintext` and `markdown` as markup kinds. - * - * If the kind is `markdown` then the value can contain fenced code blocks like in GitHub issues. - * See https://help.github.com/articles/creating-and-highlighting-code-blocks/#syntax-highlighting - * - * Here is an example how such a string can be constructed using JavaScript / TypeScript: - * ```ts - * let markdown: MarkdownContent = { - * kind: MarkupKind.Markdown, - * value: [ - * '# Header', - * 'Some text', - * '```typescript', - * 'someCode();', - * '```' - * ].join('\n') - * }; - * ``` - * - * *Please Note* that clients might sanitize the return markdown. A client could decide to - * remove HTML from the markdown to avoid script execution. - */ -export interface MarkupContent { - /** - * The type of the Markup - */ - kind: MarkupKind; - - /** - * The content itself - */ - value: string; -} --} - -- | A `MarkupContent` literal represents a string value which content is interpreted base on its -- | kind flag. Currently the protocol supports `plaintext` and `markdown` as markup kinds. -- | diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs index ba7d3c421..f7411aa13 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Progress.hs @@ -31,50 +31,6 @@ instance A.FromJSON ProgressToken where parseJSON (A.Number i) = ProgressNumericToken <$> A.parseJSON (A.Number i) parseJSON v = fail $ "Invalid progress token: " ++ show v -{- -Progress Begin Notification - -To start progress reporting a $/progress notification with the following payload must be sent: - -export interface WorkDoneProgressBegin { - - kind: 'begin'; - - /** - * Mandatory title of the progress operation. Used to briefly inform about - * the kind of operation being performed. - * - * Examples: "Indexing" or "Linking dependencies". - */ - title: string; - - /** - * Controls if a cancel button should show to allow the user to cancel the - * long running operation. Clients that don't support cancellation are allowed - * to ignore the setting. - */ - cancellable?: boolean; - - /** - * Optional, more detailed associated progress message. Contains - * complementary information to the `title`. - * - * Examples: "3/25 files", "project/src/module2", "node_modules/some_dep". - * If unset, the previous progress message (if any) is still valid. - */ - message?: string; - - /** - * Optional progress percentage to display (value 100 is considered 100%). - * If not provided infinite progress is assumed and clients are allowed - * to ignore the `percentage` value in subsequent in report notifications. - * - * The value should be steadily rising. Clients are free to ignore values - * that are not following this rule. - */ - percentage?: number; --} - -- | Parameters for a $/progress notification. data ProgressParams t = ProgressParams { @@ -150,48 +106,10 @@ instance A.FromJSON WorkDoneProgressBeginParams where _percentage <- o A..:? "percentage" pure WorkDoneProgressBeginParams{..} --- | The $/progress begin notification is sent from the server to the +-- The $/progress begin notification is sent from the server to the -- client to ask the client to start progress. -- -- @since 0.10.0.0 -{- -Progress Report Notification - -Reporting progress is done using the following payload: - -export interface WorkDoneProgressReport { - - kind: 'report'; - - /** - * Controls enablement state of a cancel button. This property is only valid if a cancel - * button got requested in the `WorkDoneProgressStart` payload. - * - * Clients that don't support cancellation or don't support control the button's - * enablement state are allowed to ignore the setting. - */ - cancellable?: boolean; - - /** - * Optional, more detailed associated progress message. Contains - * complementary information to the `title`. - * - * Examples: "3/25 files", "project/src/module2", "node_modules/some_dep". - * If unset, the previous progress message (if any) is still valid. - */ - message?: string; - - /** - * Optional progress percentage to display (value 100 is considered 100%). - * If not provided infinite progress is assumed and clients are allowed - * to ignore the `percentage` value in subsequent in report notifications. - * - * The value should be steadily rising. Clients are free to ignore values - * that are not following this rule. - */ - percentage?: number; -} --} -- | Parameters for 'WorkDoneProgressReportNotification' -- @@ -231,26 +149,10 @@ instance A.FromJSON WorkDoneProgressReportParams where _percentage <- o A..:? "percentage" pure WorkDoneProgressReportParams{..} --- | The workdone $/progress report notification is sent from the server to the +-- The workdone $/progress report notification is sent from the server to the -- client to report progress for a previously started progress. -- -- @since 0.10.0.0 -{- -Progress End Notification - -Signaling the end of a progress reporting is done using the following payload: - -export interface WorkDoneProgressEnd { - - kind: 'end'; - - /** - * Optional, a final message indicating to for example indicate the outcome - * of the operation. - */ - message?: string; -} --} -- | Parameters for 'WorkDoneProgressEndNotification'. -- @@ -274,26 +176,10 @@ instance A.FromJSON WorkDoneProgressEndParams where _message <- o A..:? "message" pure WorkDoneProgressEndParams{..} --- | The $/progress end notification is sent from the server to the +-- The $/progress end notification is sent from the server to the -- client to stop a previously started progress. -- -- @since 0.10.0.0 -{- -Progress Cancel Notification - -The window/workDoneProgress/cancel notification is sent from the client to the server to inform the server that the user has pressed the cancel button on the progress UX. A server receiving a cancel request must still close a progress using the done notification. - -Notification: - -method: 'window/workDoneProgress/cancel' -params: WorkDoneProgressCancelParams defined as follows: -export interface WorkDoneProgressCancelParams { - /** - * The token to be used to report progress. - */ - token: ProgressToken; -} --} -- | Parameters for 'WorkDoneProgressCancelNotification'. -- @@ -307,7 +193,7 @@ data WorkDoneProgressCancelParams = deriveJSON lspOptions ''WorkDoneProgressCancelParams --- | The window/workDoneProgress/cancel notification is sent from the client to the server +-- The window/workDoneProgress/cancel notification is sent from the client to the server -- to inform the server that the user has pressed the cancel button on the progress UX. -- A server receiving a cancel request must still close a progress using the done notification. -- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs index 22cc02699..5bcca0849 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs @@ -15,21 +15,7 @@ import Language.Haskell.LSP.Types.Uri import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- -{- -TextDocumentIdentifier - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#textdocumentidentifier -Text documents are identified using a URI. On the protocol level, URIs are -passed as strings. The corresponding JSON structure looks like this: - -interface TextDocumentIdentifier { - /** - * The text document's URI. - */ - uri: string; -} --} data TextDocumentIdentifier = TextDocumentIdentifier { _uri :: Uri @@ -42,37 +28,6 @@ makeExtendingDatatype "VersionedTextDocumentIdentifier" [''TextDocumentIdentifie [ ("_version", [t| TextDocumentVersion |])] deriveJSON lspOptions ''VersionedTextDocumentIdentifier -{- -TextDocumentItem - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#textdocumentitem - - New: An item to transfer a text document from the client to the server. - -interface TextDocumentItem { - /** - * The text document's URI. - */ - uri: string; - - /** - * The text document's language identifier. - */ - languageId: string; - - /** - * The version number of this document (it will strictly increase after each - * change, including undo/redo). - */ - version: number; - - /** - * The content of the opened text document. - */ - text: string; -} --} - data TextDocumentItem = TextDocumentItem { _uri :: Uri @@ -84,27 +39,7 @@ data TextDocumentItem = deriveJSON lspOptions ''TextDocumentItem -- --------------------------------------------------------------------- -{- -TextDocumentPositionParams - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#textdocumentpositionparams - - Changed: Was TextDocumentPosition in 1.0 with inlined parameters - -interface TextDocumentPositionParams { - /** - * The text document. - */ - textDocument: TextDocumentIdentifier; - - /** - * The position inside the text document. - */ - position: Position; -} - --} data TextDocumentPositionParams = TextDocumentPositionParams { -- | The text document. diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs index bd1fe52e4..983f162ad 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Window.hs @@ -10,52 +10,7 @@ import Data.Text (Text) import Language.Haskell.LSP.Types.Utils -- --------------------------------------------------------------------- -{- -ShowMessage Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#showmessage-notification - -The show message notification is sent from a server to a client to ask the -client to display a particular message in the user interface. - -Notification: - - method: 'window/showMessage' - params: ShowMessageParams defined as follows: - -interface ShowMessageParams { - /** - * The message type. See {@link MessageType}. - */ - type: number; - - /** - * The actual message. - */ - message: string; -} - -Where the type is defined as follows: - -enum MessageType { - /** - * An error message. - */ - Error = 1, - /** - * A warning message. - */ - Warning = 2, - /** - * An information message. - */ - Info = 3, - /** - * A log message. - */ - Log = 4 -} --} + data MessageType = MtError -- ^ Error = 1, | MtWarning -- ^ Warning = 2, | MtInfo -- ^ Info = 3, @@ -87,52 +42,6 @@ data ShowMessageParams = deriveJSON lspOptions ''ShowMessageParams -- --------------------------------------------------------------------- -{- -ShowMessage Request - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#showmessage-request - - New: The show message request is sent from a server to a client to ask the - client to display a particular message in the user interface. In addition to - the show message notification the request allows to pass actions and to wait - for an answer from the client. - -Request: - - method: 'window/showMessageRequest' - params: ShowMessageRequestParams defined as follows: - -Response: - - result: the selected MessageActionItem - error: code and message set in case an exception happens during showing a message. - -interface ShowMessageRequestParams { - /** - * The message type. See {@link MessageType} - */ - type: number; - - /** - * The actual message - */ - message: string; - - /** - * The message action items to present. - */ - actions?: MessageActionItem[]; -} - -Where the MessageActionItem is defined as follows: - -interface MessageActionItem { - /** - * A short title like 'Retry', 'Open Log' etc. - */ - title: string; -} --} data MessageActionItem = MessageActionItem @@ -152,33 +61,6 @@ data ShowMessageRequestParams = deriveJSON lspOptions ''ShowMessageRequestParams -- --------------------------------------------------------------------- -{- -LogMessage Notification - -https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#logmessage-notification - -The log message notification is sent from the server to the client to ask the -client to log a particular message. - -Notification: - - method: 'window/logMessage' - params: LogMessageParams defined as follows: - -interface LogMessageParams { - /** - * The message type. See {@link MessageType} - */ - type: number; - - /** - * The actual message - */ - message: string; -} - -Where type is defined as above. --} data LogMessageParams = LogMessageParams { diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs index 4a5c71aab..4898ef993 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs @@ -8,47 +8,6 @@ import Data.Text ( Text ) import Language.Haskell.LSP.Types.Common import Language.Haskell.LSP.Types.Utils -{- -Workspace folders request (:arrow_right_hook:) -Since version 3.6.0 - -Many tools support more than one root folder per workspace. Examples for this -are VS Code’s multi-root support, Atom’s project folder support or Sublime’s -project support. If a client workspace consists of multiple roots then a server -typically needs to know about this. The protocol up to now assumes one root -folder which is announce to the server by the rootUri property of the -InitializeParams. If the client supports workspace folders and announces them -via the corrsponding workspaceFolders client capability the InitializeParams -contain an additional property workspaceFolders with the configured workspace -folders when the server starts. - -The workspace/workspaceFolders request is sent from the server to the client to -fetch the current open list of workspace folders. Returns null in the response -if only a single file is open in the tool. Returns an empty array if a workspace -is open but no folders are configured. - -Request: - -method: ‘workspace/workspaceFolders’ -params: none -Response: - -result: WorkspaceFolder[] | null defines as follows: -export interface WorkspaceFolder { - /** - * The associated URI for this workspace folder. - */ - uri: string; - - /** - * The name of the workspace folder. Defaults to the - * uri's basename. - */ - name: string; -} -error: code and message set in case an exception happens during the ‘workspace/workspaceFolders’ request --} - data WorkspaceFolder = WorkspaceFolder { -- | The name of the workspace folder. Defaults to the uri's basename. @@ -58,51 +17,6 @@ data WorkspaceFolder = } deriving (Read, Show, Eq) deriveJSON lspOptions ''WorkspaceFolder -{- -DidChangeWorkspaceFolders Notification (:arrow_right:) -Since version 3.6.0 - -The workspace/didChangeWorkspaceFolders notification is sent from the client to -the server to inform the server about workspace folder configuration changes. -The notification is sent by default if both -ServerCapabilities/workspace/workspaceFolders and -ClientCapabilities/workspace/workspaceFolders are true; or if the server has -registered to receive this notification it first. To register for the -workspace/didChangeWorkspaceFolders send a client/registerCapability request -from the client to the server. The registration parameter must have a -registrations item of the following form, where id is a unique id used to -unregister the capability (the example uses a UUID): - -{ - id: "28c6150c-bd7b-11e7-abc4-cec278b6b50a", - method: "workspace/didChangeWorkspaceFolders" -} -Notification: - -method: ‘workspace/didChangeWorkspaceFolders’ -params: DidChangeWorkspaceFoldersParams defined as follows: -export interface DidChangeWorkspaceFoldersParams { - /** - * The actual workspace folder change event. - */ - event: WorkspaceFoldersChangeEvent; -} - -/** - * The workspace folder change event. - */ -export interface WorkspaceFoldersChangeEvent { - /** - * The array of added workspace folders - */ - added: WorkspaceFolder[]; - - /** - * The array of the removed workspace folders - */ - removed: WorkspaceFolder[]; -} --} -- | The workspace folder change event. data WorkspaceFoldersChangeEvent = From d1c7f617f9958d93e410d25bf38f700d5ce78998 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 18 Aug 2020 19:37:24 +0100 Subject: [PATCH 26/63] Fix haskell-lsp building with haskell-lsp-types --- .../src/Language/Haskell/LSP/Types/Command.hs | 4 +- .../src/Language/Haskell/LSP/Types/Common.hs | 2 +- .../Language/Haskell/LSP/Types/Diagnostic.hs | 2 +- src/Language/Haskell/LSP/Core.hs | 38 +++++++++---------- src/Language/Haskell/LSP/Diagnostics.hs | 4 +- src/Language/Haskell/LSP/VFS.hs | 2 +- 6 files changed, 26 insertions(+), 26 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs index a6a9bc2c4..396079784 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Command.hs @@ -23,7 +23,7 @@ deriveJSON lspOptions ''ExecuteCommandClientCapabilities -- ------------------------------------- makeExtendingDatatype "ExecuteCommandOptions" [''WorkDoneProgressOptions] - [("_commands", [t| List String |])] + [("_commands", [t| List Text |])] deriveJSON lspOptions ''ExecuteCommandOptions makeExtendingDatatype "ExecuteCommandRegistrationOptions" [''ExecuteCommandOptions] [] @@ -33,7 +33,7 @@ deriveJSON lspOptions ''ExecuteCommandRegistrationOptions makeExtendingDatatype "ExecuteCommandParams" [''WorkDoneProgressParams] [ ("_command", [t| Text |]) - , ("_arguments", [t| Maybe (List Value ) |]) + , ("_arguments", [t| Maybe (List Value) |]) ] deriveJSON lspOptions ''ExecuteCommandParams diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index d907749a0..e262cd1e8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -16,7 +16,7 @@ import GHC.Generics -- converting to and from JSON. data a |? b = L a | R b - deriving (Read,Show,Eq,Generic) + deriving (Read,Show,Eq,Ord,Generic) infixr |? instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs index 1fd4890de..6cbc13000 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Diagnostic.hs @@ -87,7 +87,7 @@ data Diagnostic = , _message :: Text , _tags :: Maybe (List DiagnosticTag) , _relatedInformation :: Maybe (List DiagnosticRelatedInformation) - } deriving (Show, Read, Eq, Generic) + } deriving (Show, Read, Eq, Ord, Generic) instance NFData Diagnostic diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 113cf7db6..a990a0440 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -453,11 +453,6 @@ getConfig = readData resConfig -- --------------------------------------------------------------------- -_ERR_MSG_URL :: [String] -_ERR_MSG_URL = [ "`stack update` and install new haskell-lsp." - , "Or check information on https://marketplace.visualstudio.com/items?itemName=xxxxxxxxxxxxxxx" - ] - defaultProgressData :: ProgressData defaultProgressData = ProgressData 0 Map.empty @@ -485,7 +480,6 @@ handleMessage jsonStr = do handleErrors = either (sendErrorLog . errMsg) id errMsg err = T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" -- --------------------------------------------------------------------- @@ -609,7 +603,8 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r sendResp $ makeResponseError (req ^. J.id) errResp Nothing -> do let capa = serverCapabilities (params ^. J.capabilities) options handlers - sendResp $ makeResponseMessage (req ^. J.id) (InitializeResponseCapabilities capa) + -- TODO: add API for serverinfo + sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult capa Nothing) case initialConfigRes of @@ -707,6 +702,7 @@ serverCapabilities clientCaps o h = { J._textDocumentSync = sync , J._hoverProvider = supportedBool J.STextDocumentHover , J._completionProvider = completionProvider + , J._declarationProvider = supportedBool J.STextDocumentDeclaration , J._signatureHelpProvider = signatureHelpProvider , J._definitionProvider = supportedBool J.STextDocumentDefinition , J._typeDefinitionProvider = supportedBool J.STextDocumentTypeDefinition @@ -714,20 +710,22 @@ serverCapabilities clientCaps o h = , J._referencesProvider = supportedBool J.STextDocumentReferences , J._documentHighlightProvider = supportedBool J.STextDocumentDocumentHighlight , J._documentSymbolProvider = supportedBool J.STextDocumentDocumentSymbol - , J._workspaceSymbolProvider = supported J.SWorkspaceSymbol , J._codeActionProvider = codeActionProvider , J._codeLensProvider = supported' J.STextDocumentCodeLens $ J.CodeLensOptions - (J.WorkDoneProgressOptions Nothing) + (Just False) (supported J.SCodeLensResolve) , J._documentFormattingProvider = supportedBool J.STextDocumentFormatting , J._documentRangeFormattingProvider = supportedBool J.STextDocumentRangeFormatting , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider , J._renameProvider = supportedBool J.STextDocumentRename - , J._documentLinkProvider = supported' J.STextDocumentDocumentLink $ J.DocumentLinkOptions $ - supported J.SDocumentLinkResolve + , J._documentLinkProvider = supported' J.STextDocumentDocumentLink $ J.DocumentLinkOptions + (Just False) + (supported J.SDocumentLinkResolve) , J._colorProvider = supportedBool J.STextDocumentDocumentColor , J._foldingRangeProvider = supportedBool J.STextDocumentFoldingRange , J._executeCommandProvider = executeCommandProvider + , J._selectionRangeProvider = supportedBool J.STextDocumentSelectionRange + , J._workspaceSymbolProvider = supported J.SWorkspaceSymbol , J._workspace = Just workspace -- TODO: Add something for experimental , J._experimental = Nothing :: Maybe J.Value @@ -754,10 +752,10 @@ serverCapabilities clientCaps o h = completionProvider | supported_b J.STextDocumentCompletion = Just $ J.CompletionOptions - (J.WorkDoneProgressOptions Nothing) - (supported J.SCompletionItemResolve) + Nothing (map singleton <$> completionTriggerCharacters o) (map singleton <$> completionAllCommitCharacters o) + (supported J.SCompletionItemResolve) | otherwise = Nothing clientSupportsCodeActionKinds = isJust $ @@ -765,16 +763,18 @@ serverCapabilities clientCaps o h = codeActionProvider | clientSupportsCodeActionKinds - , supported_b J.STextDocumentCodeAction = Just $ maybe (J.L True) (J.R . J.CodeActionOptions . Just) (codeActionKinds o) + , supported_b J.STextDocumentCodeAction = Just $ + maybe (J.L True) (J.R . J.CodeActionOptions Nothing . Just . J.List) + (codeActionKinds o) | supported_b J.STextDocumentCodeAction = Just (J.L True) | otherwise = Just (J.L False) signatureHelpProvider | supported_b J.STextDocumentSignatureHelp = Just $ J.SignatureHelpOptions - (J.WorkDoneProgressOptions Nothing) - (map singleton <$> signatureHelpTriggerCharacters o) - (map singleton <$> signatureHelpRetriggerCharacters o) + Nothing + (J.List . map singleton <$> signatureHelpTriggerCharacters o) + (J.List . map singleton <$> signatureHelpRetriggerCharacters o) | otherwise = Nothing documentOnTypeFormattingProvider @@ -788,14 +788,14 @@ serverCapabilities clientCaps o h = executeCommandProvider | supported_b J.SWorkspaceExecuteCommand - , Just cmds <- executeCommandCommands o = Just (J.ExecuteCommandOptions (J.List cmds)) + , Just cmds <- executeCommandCommands o = Just (J.ExecuteCommandOptions Nothing (J.List cmds)) | supported_b J.SWorkspaceExecuteCommand , Nothing <- executeCommandCommands o = error "executeCommandCommands needs to be set if a executeCommandHandler is set" | otherwise = Nothing sync = case textDocumentSync o of - Just x -> Just (J.TDSOptions x) + Just x -> Just (J.L x) Nothing -> Nothing workspace = J.WorkspaceServerCapabilities workspaceFolder diff --git a/src/Language/Haskell/LSP/Diagnostics.hs b/src/Language/Haskell/LSP/Diagnostics.hs index d40eceae4..5851717a8 100644 --- a/src/Language/Haskell/LSP/Diagnostics.hs +++ b/src/Language/Haskell/LSP/Diagnostics.hs @@ -91,7 +91,7 @@ getDiagnosticParamsFor :: Int -> DiagnosticStore -> J.NormalizedUri -> Maybe J.P getDiagnosticParamsFor maxDiagnostics ds uri = case HM.lookup uri ds of Nothing -> Nothing - Just (StoreItem _ diags) -> - Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags)) + Just (StoreItem mv diags) -> + Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) mv (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags)) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs index 062efbaee..002491223 100644 --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -132,7 +132,7 @@ updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap } -- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' changeFromServerVFS :: VFS -> J.ApplyWorkspaceEditRequest -> IO VFS changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do - let J.ApplyWorkspaceEditParams edit = params + let J.ApplyWorkspaceEditParams _label edit = params J.WorkspaceEdit mChanges mDocChanges = edit case mDocChanges of Just (J.List textDocEdits) -> applyEdits textDocEdits From 870de779f1fe669e0b8b0335aef60b19b30ede9a Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 18 Aug 2020 20:15:28 +0100 Subject: [PATCH 27/63] Remove 8.2.2 support, and remove all CPP --- example/Main.hs | 4 ---- .../src/Language/Haskell/LSP/Types/Common.hs | 8 +------- .../Language/Haskell/LSP/Types/DocumentFilter.hs | 12 ++++++------ .../src/Language/Haskell/LSP/Types/Hover.hs | 13 ++++--------- .../Language/Haskell/LSP/Types/MarkupContent.hs | 11 +++-------- .../src/Language/Haskell/LSP/Types/Uri.hs | 4 ---- .../Language/Haskell/LSP/Types/WorkspaceEdit.hs | 11 ++--------- src/Language/Haskell/LSP/Control.hs | 4 ---- src/Language/Haskell/LSP/VFS.hs | 1 - stack-8.2.2.yaml | 12 ------------ test/ServerCapabilitiesSpec.hs | 4 ---- test/TypesSpec.hs | 4 ---- test/URIFilePathSpec.hs | 15 --------------- 13 files changed, 16 insertions(+), 87 deletions(-) delete mode 100644 stack-8.2.2.yaml diff --git a/example/Main.hs b/example/Main.hs index 66ed6c231..031404188 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -34,9 +33,6 @@ import Control.Monad.STM import qualified Data.Aeson as J import Data.Default import qualified Data.HashMap.Strict as H -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid -#endif import qualified Data.Text as T import qualified Language.Haskell.LSP.Control as CTRL import qualified Language.Haskell.LSP.Core as Core diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index e262cd1e8..87206b7af 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveGeneric #-} @@ -31,7 +30,7 @@ instance (NFData a, NFData b) => NFData (a |? b) -- | This data type is used to host a FromJSON instance for the encoding used by -- elisp, where an empty list shows up as "null" newtype List a = List [a] - deriving (Show,Read,Eq,Ord,Monoid,Functor,Foldable,Traversable,Generic) + deriving (Show,Read,Eq,Ord,Semigroup,Monoid,Functor,Foldable,Traversable,Generic) instance NFData a => NFData (List a) @@ -42,11 +41,6 @@ instance (FromJSON a) => FromJSON (List a) where parseJSON Null = return (List []) parseJSON v = List <$> parseJSON v -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup (List a) where - (<>) = mappend -#endif - data Empty = Empty deriving (Eq,Ord,Show) instance ToJSON Empty where toJSON Empty = Null diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs index 223a7e654..ce5de929c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DocumentFilter.hs @@ -17,12 +17,12 @@ data DocumentFilter = , -- | A glob pattern, like `*.{ts,js}`. -- -- Glob patterns can have the following syntax: - -- - @*@ to match one or more characters in a path segment - -- - @?@ to match on one character in a path segment - -- - @**@ to match any number of path segments, including none - -- - @{}@ to group conditions (e.g. @**​/*.{ts,js}@ matches all TypeScript and JavaScript files) - -- - @[]@ to declare a range of characters to match in a path segment (e.g., @example.[0-9]@ to match on @example.0@, @example.1@, …) - -- - @[!...]@ to negate a range of characters to match in a path segment (e.g., @example.[!0-9]@ to match on @example.a@, @example.b@, but not @example.0@) + -- - @*@ to match one or more characters in a path segment + -- - @?@ to match on one character in a path segment + -- - @**@ to match any number of path segments, including none + -- - @{}@ to group conditions (e.g. @**​/*.{ts,js}@ matches all TypeScript and JavaScript files) + -- - @[]@ to declare a range of characters to match in a path segment (e.g., @example.[0-9]@ to match on @example.0@, @example.1@, …) + -- - @[!...]@ to negate a range of characters to match in a path segment (e.g., @example.[!0-9]@ to match on @example.a@, @example.b@, but not @example.0@) _pattern :: Maybe Text } deriving (Show, Read, Eq) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs index cf398294a..2ea5d3f6b 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} module Language.Haskell.LSP.Types.Hover where @@ -76,19 +75,15 @@ instance FromJSON HoverContents where -- ------------------------------------- -#if __GLASGOW_HASKELL__ >= 804 instance Semigroup HoverContents where - (<>) = mappend -#endif + HoverContents h1 <> HoverContents h2 = HoverContents (h1 `mappend` h2) + HoverContents h1 <> HoverContentsMS (List h2s) = HoverContents (mconcat (h1: (map toMarkupContent h2s))) + HoverContentsMS (List h1s) <> HoverContents h2 = HoverContents (mconcat ((map toMarkupContent h1s) ++ [h2])) + HoverContentsMS (List h1s) <> HoverContentsMS (List h2s) = HoverContentsMS (List (h1s `mappend` h2s)) instance Monoid HoverContents where mempty = HoverContentsMS (List []) - HoverContents h1 `mappend` HoverContents h2 = HoverContents (h1 `mappend` h2) - HoverContents h1 `mappend` HoverContentsMS (List h2s) = HoverContents (mconcat (h1: (map toMarkupContent h2s))) - HoverContentsMS (List h1s) `mappend` HoverContents h2 = HoverContents (mconcat ((map toMarkupContent h1s) ++ [h2])) - HoverContentsMS (List h1s) `mappend` HoverContentsMS (List h2s) = HoverContentsMS (List (h1s `mappend` h2s)) - toMarkupContent :: MarkedString -> MarkupContent toMarkupContent (PlainString s) = unmarkedUpContent s toMarkupContent (CodeString (LanguageString lang s)) = markedUpContent lang s diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs index dc7de0e63..50ec0be9f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -12,7 +11,6 @@ module Language.Haskell.LSP.Types.MarkupContent where import Data.Aeson import Data.Aeson.TH -import Data.Monoid ((<>)) import Data.Text (Text) import Language.Haskell.LSP.Types.Utils @@ -83,16 +81,13 @@ sectionSeparator = "* * *\n" -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 804 instance Semigroup MarkupContent where - (<>) = mappend -#endif + MarkupContent MkPlainText s1 <> MarkupContent MkPlainText s2 = MarkupContent MkPlainText (s1 `mappend` s2) + MarkupContent MkMarkdown s1 <> MarkupContent _ s2 = MarkupContent MkMarkdown (s1 `mappend` s2) + MarkupContent _ s1 <> MarkupContent MkMarkdown s2 = MarkupContent MkMarkdown (s1 `mappend` s2) instance Monoid MarkupContent where mempty = MarkupContent MkPlainText "" - MarkupContent MkPlainText s1 `mappend` MarkupContent MkPlainText s2 = MarkupContent MkPlainText (s1 `mappend` s2) - MarkupContent MkMarkdown s1 `mappend` MarkupContent _ s2 = MarkupContent MkMarkdown (s1 `mappend` s2) - MarkupContent _ s1 `mappend` MarkupContent MkMarkdown s2 = MarkupContent MkMarkdown (s1 `mappend` s2) -- --------------------------------------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs index b6843a826..bf7b449bb 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -25,9 +24,6 @@ import qualified Data.Aeson as A import Data.Binary (Binary, Get, put, get) import Data.Hashable import Data.List (stripPrefix) -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid ((<>)) -#endif import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs index 8565f0985..a37746064 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceEdit.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,8 +6,6 @@ module Language.Haskell.LSP.Types.WorkspaceEdit where import Data.Aeson import Data.Aeson.TH import qualified Data.HashMap.Strict as H --- For <= 8.2.2 -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -49,14 +46,10 @@ data WorkspaceEdit = , _documentChanges :: Maybe (List TextDocumentEdit) } deriving (Show, Read, Eq) +instance Semigroup WorkspaceEdit where + (WorkspaceEdit a b) <> (WorkspaceEdit c d) = WorkspaceEdit (a <> c) (b <> d) instance Monoid WorkspaceEdit where mempty = WorkspaceEdit Nothing Nothing - mappend (WorkspaceEdit a b) (WorkspaceEdit c d) = WorkspaceEdit (a <> c) (b <> d) - -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup WorkspaceEdit where - (<>) = mappend -#endif deriveJSON lspOptions ''WorkspaceEdit diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs index 7ccda8f4f..d040a0fea 100644 --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} @@ -21,9 +20,6 @@ import qualified Data.ByteString as BS import Data.ByteString.Builder.Extra (defaultChunkSize) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid -#endif import qualified Language.Haskell.LSP.Core as Core import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Utility diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs index 002491223..c310ad0a6 100644 --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml deleted file mode 100644 index 990a002a7..000000000 --- a/stack-8.2.2.yaml +++ /dev/null @@ -1,12 +0,0 @@ -resolver: lts-11.20 # GHC 8.2.2 version - -packages: -- '.' -- ./haskell-lsp-types -extra-deps: -- sorted-list-0.2.1.0 -- rope-utf16-splay-0.3.1.0 -flags: {} -extra-package-dbs: [] -nix: - packages: [icu] diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs index c3e3c0550..7297374a5 100644 --- a/test/ServerCapabilitiesSpec.hs +++ b/test/ServerCapabilitiesSpec.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module ServerCapabilitiesSpec where import Control.Lens.Operators import Data.Aeson -#if __GLASGOW_HASKELL__ < 808 -import Data.Monoid ((<>)) -#endif import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens import Test.Hspec diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs index 67501bea4..3574e5269 100644 --- a/test/TypesSpec.hs +++ b/test/TypesSpec.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module TypesSpec where -#if __GLASGOW_HASKELL__ < 808 -import Data.Monoid ((<>)) -#endif import qualified Language.Haskell.LSP.Types as J import Test.Hspec diff --git a/test/URIFilePathSpec.hs b/test/URIFilePathSpec.hs index 8726ca51d..9c2a1068b 100644 --- a/test/URIFilePathSpec.hs +++ b/test/URIFilePathSpec.hs @@ -1,21 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module URIFilePathSpec where import Control.Monad (when) import Data.List -#if __GLASGOW_HASKELL__ < 808 -import Data.Monoid ((<>)) -#endif import Data.Text (Text, pack) import Language.Haskell.LSP.Types import Network.URI import Test.Hspec import Test.QuickCheck -#if !MIN_VERSION_QuickCheck(2,10,0) -import Data.Char (GeneralCategory(..), generalCategory) -#endif import qualified System.FilePath.Windows as FPW import System.FilePath (normalise) import qualified System.Info @@ -255,14 +248,6 @@ genValidUnicodeChar :: Gen Char genValidUnicodeChar = arbitraryUnicodeChar `suchThat` isCharacter where isCharacter x = x /= '\65534' && x /= '\65535' -#if !MIN_VERSION_QuickCheck(2,10,0) -arbitraryUnicodeChar :: Gen Char -arbitraryUnicodeChar = - arbitraryBoundedEnum `suchThat` (not . isSurrogate) - where - isSurrogate c = generalCategory c == Surrogate -#endif - normalizedFilePathSpec :: Spec normalizedFilePathSpec = do it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do From 0ec7661985b806a5900fec4b2c189a5e3b536f65 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Thu, 20 Aug 2020 22:44:46 +0530 Subject: [PATCH 28/63] DMap wip DMap complete use Data.GADT.Compare from hackage --- haskell-lsp-types/haskell-lsp-types.cabal | 1 + .../src/Language/Haskell/LSP/Types/Message.hs | 26 +--- .../src/Language/Haskell/LSP/Types/Method.hs | 4 + haskell-lsp.cabal | 1 + src/Language/Haskell/LSP/Core.hs | 139 ++++++++++-------- 5 files changed, 90 insertions(+), 81 deletions(-) diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index 162ee3789..b8362e5c5 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -80,6 +80,7 @@ library , network-uri , scientific , some + , dependent-sum-template , text , template-haskell , unordered-containers diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 611c65f8e..2ee89b3ec 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -382,20 +382,6 @@ type family BaseMessage (t :: MethodType) :: Method p t -> Type where type HandlerFunc a = Either ResponseError a -> IO () --- | Map a method to a handler for its response --- Either ResponseError (ResponseParams m) -> IO () for Requests --- () for Notifications --- This is a callback that will be invoked when your request --- recieves a response --- Custom methods can either be a notification or a request, so --- it may or may not have a response handler! -type family ResponseHandlerFunc m :: Type where - ResponseHandlerFunc (m :: Method p t) = BaseHandlerFunc t m - -type family BaseHandlerFunc (t :: MethodType) (m :: Method p t) :: Type where - BaseHandlerFunc Request m = HandlerFunc (ResponseParams m) - BaseHandlerFunc Notification m = () - -- Some helpful type synonyms type ClientMessage (m :: Method FromClient t) = Message m type ServerMessage (m :: Method FromServer t) = Message m @@ -546,15 +532,13 @@ type HasJSON a = (ToJSON a,FromJSON a,Eq a) data ClientNotOrReq (m :: Method FromClient t) where IsClientNot :: ( HasJSON (ClientMessage m) - , Message m ~ NotificationMessage m - , ResponseHandlerFunc m ~ ()) + , Message m ~ NotificationMessage m) => ClientNotOrReq (m :: Method FromClient Notification) IsClientReq :: forall (m :: Method FromClient Request). ( HasJSON (ClientMessage m) , HasJSON (ResponseMessage m) - , Message m ~ RequestMessage m - , ResponseHandlerFunc m ~ HandlerFunc (ResponseParams m)) + , Message m ~ RequestMessage m) => ClientNotOrReq m IsClientEither :: ClientNotOrReq CustomMethod @@ -562,15 +546,13 @@ data ClientNotOrReq (m :: Method FromClient t) where data ServerNotOrReq (m :: Method FromServer t) where IsServerNot :: ( HasJSON (ServerMessage m) - , Message m ~ NotificationMessage m - , ResponseHandlerFunc m ~ ()) + , Message m ~ NotificationMessage m) => ServerNotOrReq (m :: Method FromServer Notification) IsServerReq :: forall (m :: Method FromServer Request). ( HasJSON (ServerMessage m) , HasJSON (ResponseMessage m) - , Message m ~ RequestMessage m - , ResponseHandlerFunc m ~ HandlerFunc (ResponseParams m)) + , Message m ~ RequestMessage m) => ServerNotOrReq m IsServerEither :: ServerNotOrReq CustomMethod diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index d7639ee5d..c49eabdc4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -16,6 +16,7 @@ import Data.Text (Text) import Language.Haskell.LSP.Types.Utils import Data.Function (on) import Control.Applicative +import Data.GADT.Compare.TH -- --------------------------------------------------------------------- @@ -161,6 +162,9 @@ data SMethod (m :: Method p t) where SCancelRequest :: SMethod CancelRequest SCustomMethod :: Text -> SMethod CustomMethod +deriveGEq ''SMethod +deriveGCompare ''SMethod + deriving instance Eq (SMethod m) deriving instance Ord (SMethod m) deriving instance Show (SMethod m) diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 6377fe8e2..8afa654ac 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -45,6 +45,7 @@ library , hslogger , hashable , haskell-lsp-types == 0.22.* + , dependent-map , lens >= 4.15.2 , mtl , network-uri diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index a990a0440..7e49d28e5 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -1,33 +1,34 @@ {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Language.Haskell.LSP.Core ( handleMessage , LanguageContextData(..) - , Handler(..) , VFSData(..) , InitializeCallbacks(..) , LspFuncs(..) , Progress(..) , ProgressCancellable(..) , ProgressCancelledException - , Handlers + , Handlers(..) , Options(..) - , ClientResponseHandler(..) + , ClientRequestHandler(..) + , ClientNotificationHandler(..) , ServerResponseHandler(..) , makeResponseMessage , makeResponseError @@ -57,6 +58,8 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B import Data.Default import Data.IxMap +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Map (DMap) import qualified Data.HashMap.Strict as HM import qualified Data.List as L import Data.List.NonEmpty (NonEmpty(..)) @@ -278,23 +281,8 @@ data InitializeCallbacks config = -- that may be necesary for the server lifecycle. } -newtype ClientResponseHandler (m :: Method FromClient t) = ClientResponseHandler (ResponseHandlerFunc m) - -newtype ServerResponseHandler (m :: Method FromServer t) = ServerResponseHandler (ResponseHandlerFunc m) - -mkClientResponseHandler :: SClientMethod m -> ClientMessage m -> LspM config (ClientResponseHandler m) -mkClientResponseHandler m cm = do - sf <- asks resSendMessage - pure $ ClientResponseHandler $ case splitClientMethod m of - IsClientNot -> () - IsClientReq -> \mrsp -> case mrsp of - Left err -> sf $ FromServerRsp m $ makeResponseError (cm ^. J.id) err - Right rsp -> sf $ FromServerRsp m $ makeResponseMessage (cm ^. J.id) rsp - IsClientEither -> case cm of - NotMess _ -> () - ReqMess req -> \mrsp -> case mrsp of - Left err -> sf $ FromServerRsp m $ makeResponseError (req ^. J.id) err - Right rsp -> sf $ FromServerRsp m $ makeResponseMessage (req ^. J.id) rsp +newtype ServerResponseHandler (m :: Method FromServer Request) + = ServerResponseHandler (HandlerFunc (ResponseParams m)) -- | Return value signals if response handler was inserted succesfully -- Might fail if the id was already in the map @@ -328,11 +316,21 @@ mkSendReqFunc m params resHandler = do IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg return reqId --- | The Handler type captures a function that receives local read-only state --- 'a', a function to send a reply message once encoded as a ByteString, and a --- received message of type 'b' -newtype Handler m = Handler {runHandler :: ClientMessage m -> ClientResponseHandler m -> IO ()} -type Handlers = forall t (m :: Method FromClient t). SMethod m -> Maybe (Handler m) +newtype ClientRequestHandler (m :: Method FromClient Request) + = ClientRequestHandler + { runRequestHandler :: RequestMessage m -> HandlerFunc (ResponseParams m) -> IO () + } + +newtype ClientNotificationHandler (m :: Method FromClient Notification) + = ClientNotificationHandler + { runNotificationHandler :: NotificationMessage m -> IO () + } + +data Handlers + = Handlers + { requestHandlers :: DMap SMethod ClientRequestHandler + , notificationHandlers :: DMap SMethod ClientNotificationHandler + } -- --------------------------------------------------------------------- nop :: Maybe (b -> LspM config ()) @@ -350,28 +348,48 @@ handlerMap c = case c of -- --------------------------------------------------------------------- +mkClientResponseHandler :: (FromServerMessage -> IO ()) -> RequestMessage (m :: Method FromClient Request) -> HandlerFunc (ResponseParams m) +mkClientResponseHandler sf req (Left err) = sf $ FromServerRsp (req ^. J.method) $ makeResponseError (req ^. J.id) err +mkClientResponseHandler sf req (Right rsp) = sf $ FromServerRsp (req ^. J.method) $ makeResponseMessage (req ^. J.id) rsp + -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop hh :: Maybe (ClientMessage m -> LspM config ()) -> SClientMethod m -> ClientMessage m -> LspM config () hh mAction m req = do maybe (return ()) (\f -> f req) mAction - getHandler <- asks resHandlers - let handleReq h = do - respH <- mkClientResponseHandler m req - liftIO $ runHandler h req respH - case getHandler m of - Just h -> handleReq h - Nothing - | SExit <- m -> handleReq exitNotificationHandler - | SShutdown <- m -> handleReq shutdownRequestHandler - -- '$/' notifications should/could be ignored by server. - -- Don't log errors in that case. - -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. - | isOptionalNotification m -> return () - | otherwise -> do + Handlers{..} <- asks resHandlers + sf <- asks resSendMessage + let mkRspH :: forall m. RequestMessage (m :: Method FromClient Request) -> HandlerFunc (ResponseParams m) + mkRspH = mkClientResponseHandler sf + ~() <- case splitClientMethod m of + IsClientNot -> case DMap.lookup m notificationHandlers of + Just h -> liftIO $ runNotificationHandler h req + Nothing + | SExit <- m -> liftIO $ runNotificationHandler exitNotificationHandler req + | otherwise -> reportMissingHandler + IsClientReq -> case DMap.lookup m requestHandlers of + Just h -> liftIO $ runRequestHandler h req $ mkRspH req + Nothing + | SShutdown <- m -> liftIO $ runRequestHandler shutdownRequestHandler req $ mkRspH req + | otherwise -> reportMissingHandler + IsClientEither -> case req of + NotMess not -> case DMap.lookup m notificationHandlers of + Just h -> liftIO $ runNotificationHandler h not + Nothing -> reportMissingHandler + ReqMess req -> case DMap.lookup m requestHandlers of + Just h -> liftIO $ runRequestHandler h req $ mkRspH req + Nothing -> reportMissingHandler + pure () + where + -- '$/' notifications should/could be ignored by server. + -- Don't log errors in that case. + -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. + reportMissingHandler :: LspM config () + reportMissingHandler + | isOptionalNotification m = return () + | otherwise = do let msg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m] sendErrorLog msg - where isOptionalNotification (SCustomMethod method) | "$/" `T.isPrefixOf` method = True isOptionalNotification _ = False @@ -744,7 +762,10 @@ serverCapabilities clientCaps o h = supported = Just . supported_b supported_b :: forall m. J.SClientMethod m -> Bool - supported_b m = isJust (h m) + supported_b m = case splitClientMethod m of + IsClientNot -> DMap.member m (notificationHandlers h) + IsClientReq -> DMap.member m (requestHandlers h) + IsClientEither -> False -- No capabilities for custom method singleton :: a -> [a] singleton x = [x] @@ -810,14 +831,14 @@ progressCancelHandler (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams Nothing -> return () Just cancelAction -> liftIO $ cancelAction -exitNotificationHandler :: Handler J.Exit -exitNotificationHandler = Handler $ \_ _ -> do +exitNotificationHandler :: ClientNotificationHandler J.Exit +exitNotificationHandler = ClientNotificationHandler $ \_ -> do logm $ B.pack "haskell-lsp:Got exit, exiting" exitSuccess -- | Default Shutdown handler -shutdownRequestHandler :: Handler J.Shutdown -shutdownRequestHandler = Handler $ \_req (ClientResponseHandler k) -> do +shutdownRequestHandler :: ClientRequestHandler J.Shutdown +shutdownRequestHandler = ClientRequestHandler $ \_req k -> do k $ Right J.Empty -- --------------------------------------------------------------------- From 3b49653bc270d5452e49d88b5793e2199bc16973 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 22 Aug 2020 01:20:52 +0530 Subject: [PATCH 29/63] A few fixes --- haskell-lsp-types/src/Language/Haskell/LSP/Types.hs | 2 ++ .../src/Language/Haskell/LSP/Types/Capabilities.hs | 2 ++ haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs | 4 ++-- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index cdd41bbeb..669b82d51 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -39,6 +39,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.WorkspaceEdit , module Language.Haskell.LSP.Types.WorkspaceFolders , module Language.Haskell.LSP.Types.WorkspaceSymbol + , module Language.Haskell.LSP.Types.Registration ) where @@ -82,3 +83,4 @@ import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders import Language.Haskell.LSP.Types.WorkspaceSymbol +import Language.Haskell.LSP.Types.Registration diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index c9c33912c..ede3f480c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -2,6 +2,7 @@ module Language.Haskell.LSP.Types.Capabilities ( module Language.Haskell.LSP.Types.ClientCapabilities , module Language.Haskell.LSP.Types.ServerCapabilities + , module Language.Haskell.LSP.Types.WorkspaceEdit , fullCaps , LSPVersion(..) , capsForVersion @@ -10,6 +11,7 @@ module Language.Haskell.LSP.Types.Capabilities import Prelude hiding (min) import Language.Haskell.LSP.Types.ClientCapabilities import Language.Haskell.LSP.Types.ServerCapabilities +import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types -- | The whole shebang. The real deal. diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs index 8f297a172..5773cbdcb 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs @@ -35,8 +35,8 @@ makeExtendingDatatype "RenameRegistrationOptions" deriveJSON lspOptions ''RenameRegistrationOptions makeExtendingDatatype "RenameParams" - [ ''TextDocumentRegistrationOptions - , ''RenameOptions + [ ''TextDocumentPositionParams + , ''WorkDoneProgressParams ] [("_newName", [t| String |])] deriveJSON lspOptions ''RenameParams From 65bb4fad1613ced4ae4c436563c27b95cadc2b35 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 20 Aug 2020 14:28:56 +0100 Subject: [PATCH 30/63] Dyn registration WIP --- example/Main.hs | 44 ++++--- .../src/Language/Haskell/LSP/Types.hs | 2 + .../Haskell/LSP/Types/Capabilities.hs | 1 + .../Haskell/LSP/Types/ClientCapabilities.hs | 10 +- .../src/Language/Haskell/LSP/Types/Lens.hs | 7 ++ .../src/Language/Haskell/LSP/Types/Rename.hs | 2 +- .../Haskell/LSP/Types/TextDocument.hs | 23 +++- haskell-lsp.cabal | 3 + hie.yaml | 2 + src/Language/Haskell/LSP/Core.hs | 118 ++++++++++++++++-- stack-8.4.4.yaml | 1 + 11 files changed, 178 insertions(+), 35 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index 031404188..168043038 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {- | This is an example language server built with haskell-lsp using a 'Reactor' @@ -100,7 +101,7 @@ syncOptions = J.TextDocumentSyncOptions , J._change = Just J.TdSyncIncremental , J._willSave = Just False , J._willSaveWaitUntil = Just False - , J._save = Just $ J.SaveOptions $ Just False + , J._save = Just $ J.R $ J.SaveOptions $ Just False } lspOptions :: Core.Options @@ -219,10 +220,13 @@ handle J.SInitialized = Just $ \_msg () -> do } } -} - let registration = J.Registration "lsp-hello-registered" - (J.SomeClientMethod J.SWorkspaceExecuteCommand) - Nothing - regParams = J.RegistrationParams (J.List [registration]) + let registration = J.Registration "code-lens" + J.STextDocumentCodeLens + (J.CodeLensRegistrationOptions + Nothing + Nothing + (Just False)) + regParams = J.RegistrationParams (J.List [J.SomeRegistration registration]) void $ reactorSendReq J.SClientRegisterCapability regParams $ \_lid res -> case res of Left e -> liftIO $ U.logs $ "Got an error: " ++ show e @@ -282,9 +286,9 @@ handle J.STextDocumentRename = Just $ \req responder -> do handle J.STextDocumentHover = Just $ \req responder -> do liftIO $ U.logs "Processing a textDocument/hover request" - let J.TextDocumentPositionParams _doc pos _workDoneToken = req ^. J.params + let J.HoverParams _doc pos _workDone = req ^. J.params J.Position _l _c' = pos - rsp = Just $ J.Hover ms (Just range) + rsp = J.Hover ms (Just range) ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" range = J.Range pos pos liftIO $ responder (Right rsp) @@ -307,7 +311,7 @@ handle J.STextDocumentCodeAction = Just $ \req responder -> do ] cmdparams = Just args makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] - rsp = J.List $ map J.CACommand $ concatMap makeCommand diags + rsp = J.List $ map J.L $ concatMap makeCommand diags liftIO $ responder (Right rsp) handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do @@ -321,6 +325,12 @@ handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do reactorSendNot J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "I was told to execute a command") +handle J.STextDocumentCodeLens = Just $ \_req responder -> do + liftIO $ U.logs "Processing a textDocument/codeLens request" + let cmd = J.Command "Say hello" "lsp-hello-command" Nothing + rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] + liftIO $ responder (Right rsp) + handle _ = Nothing -- --------------------------------------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 669b82d51..33e31ab44 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -25,6 +25,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Message , module Language.Haskell.LSP.Types.Progress , module Language.Haskell.LSP.Types.References + , module Language.Haskell.LSP.Types.Registration , module Language.Haskell.LSP.Types.Rename , module Language.Haskell.LSP.Types.SignatureHelp , module Language.Haskell.LSP.Types.StaticRegistrationOptions @@ -69,6 +70,7 @@ import Language.Haskell.LSP.Types.Method import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.References +import Language.Haskell.LSP.Types.Registration import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.SignatureHelp diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index ede3f480c..0f4b336a1 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -119,6 +119,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth (Just (RenameClientCapabilities dynamicReg (since 3 12 True))) (Just publishDiagnosticsCapabilities) (since 3 10 foldingRangeCapability) + (since 3 5 (SelectionRangeClientCapabilities dynamicReg)) sync = TextDocumentSyncClientCapabilities dynamicReg diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs index 667c2e098..6ad409f84 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -24,6 +24,7 @@ import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Implementation import Language.Haskell.LSP.Types.References import Language.Haskell.LSP.Types.Rename +import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition @@ -132,10 +133,15 @@ data TextDocumentClientCapabilities = -- | Capabilities specific to `textDocument/publishDiagnostics` , _publishDiagnostics :: Maybe PublishDiagnosticsClientCapabilities - -- | Capabilities specific to `textDocument/foldingRange` requests. Since LSP 3.10. + -- | Capabilities specific to the `textDocument/foldingRange` request. + -- Since LSP 3.10. -- -- @since 0.7.0.0 , _foldingRange :: Maybe FoldingRangeClientCapabilities + + -- | Capabilities specific to the `textDocument/selectionRange` request. + -- Since LSP 3.15.0 + , _selectionRange :: Maybe SelectionRangeClientCapabilities } deriving (Show, Read, Eq) deriveJSON lspOptions ''TextDocumentClientCapabilities @@ -143,7 +149,7 @@ deriveJSON lspOptions ''TextDocumentClientCapabilities instance Default TextDocumentClientCapabilities where def = TextDocumentClientCapabilities def def def def def def def def def def def def def def def def - def def def def def + def def def def def def -- --------------------------------------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 80becd956..93ae7ccf5 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -16,6 +16,7 @@ import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.Command import Language.Haskell.LSP.Types.Completion import Language.Haskell.LSP.Types.Configuration +import Language.Haskell.LSP.Types.Declaration import Language.Haskell.LSP.Types.Definition import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter @@ -146,6 +147,12 @@ makeFieldsNoPrefix ''CompletionList makeFieldsNoPrefix ''CompletionParams makeFieldsNoPrefix ''CompletionRegistrationOptions +-- Declaration +makeFieldsNoPrefix ''DeclarationClientCapabilities +makeFieldsNoPrefix ''DeclarationOptions +makeFieldsNoPrefix ''DeclarationRegistrationOptions +makeFieldsNoPrefix ''DeclarationParams + -- CodeActions makeFieldsNoPrefix ''CodeActionKindClientCapabilities makeFieldsNoPrefix ''CodeActionLiteralSupport diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs index 5773cbdcb..f39e32b83 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Rename.hs @@ -38,7 +38,7 @@ makeExtendingDatatype "RenameParams" [ ''TextDocumentPositionParams , ''WorkDoneProgressParams ] - [("_newName", [t| String |])] + [("_newName", [t| Text |])] deriveJSON lspOptions ''RenameParams -- ----------------------------------------- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs index 5bcca0849..c7f9e8e30 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/TextDocument.hs @@ -79,6 +79,14 @@ instance Default TextDocumentSyncClientCapabilities where -- ------------------------------------- +data SaveOptions = + SaveOptions + { -- | The client is supposed to include the content on save. + _includeText :: Maybe Bool + } deriving (Show, Read, Eq) + +-- ------------------------------------- + -- | Defines how the host (editor) should sync document changes to the language server. data TextDocumentSyncKind = -- | Documents should not be synced at all. @@ -110,6 +118,15 @@ data TextDocumentSyncOptions = -- and TextDocumentSyncKind.Incremental. If omitted it defaults to -- TextDocumentSyncKind.None. _change :: Maybe TextDocumentSyncKind + -- | If present will save notifications are sent to the server. If omitted the notification should not be + -- sent. + , _willSave :: Maybe Bool + -- | If present will save wait until requests are sent to the server. If omitted the request should not be + -- sent. + , _willSaveWaitUntil :: Maybe Bool + -- | If present save notifications are sent to the server. If omitted the + -- notification should not be sent. + , _save :: Maybe (Bool |? SaveOptions) } deriving (Show, Read, Eq) deriveJSON lspOptions ''TextDocumentSyncOptions @@ -217,12 +234,6 @@ deriveJSON lspOptions ''WillSaveTextDocumentParams -- ------------------------------------- -data SaveOptions = - SaveOptions - { -- | The client is supposed to include the content on save. - _includeText :: Maybe Bool - } deriving (Show, Read, Eq) - deriveJSON lspOptions ''SaveOptions makeExtendingDatatype "TextDocumentSaveRegistrationOptions" diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 8afa654ac..e61b7d944 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -58,6 +58,9 @@ library , transformers , time , unordered-containers + -- used for generating random uuids for dynamic registration + , random + , uuid hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -fprint-explicit-kinds diff --git a/hie.yaml b/hie.yaml index ce7f616b4..72220d7d0 100644 --- a/hie.yaml +++ b/hie.yaml @@ -11,3 +11,5 @@ cradle: component: "haskell-lsp-types" - path: "./src" component: "haskell-lsp" + - path: "./example" + component: "lsp-hello" diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 7e49d28e5..ca2ef7e14 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -15,6 +15,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fprint-explicit-kinds #-} + module Language.Haskell.LSP.Core ( handleMessage @@ -26,6 +28,7 @@ module Language.Haskell.LSP.Core ( , ProgressCancellable(..) , ProgressCancelledException , Handlers(..) + , RegistrationId , Options(..) , ClientRequestHandler(..) , ClientNotificationHandler(..) @@ -68,6 +71,7 @@ import Data.Maybe import Data.Monoid hiding (Product) import qualified Data.Text as T import Data.Text ( Text ) +import qualified Data.UUID as UUID import Language.Haskell.LSP.Constant -- import Language.Haskell.LSP.Types.MessageFuncs import qualified Language.Haskell.LSP.Types.Capabilities as J @@ -84,6 +88,7 @@ import qualified System.Log.Handler as LH import qualified System.Log.Handler.Simple as LHS import System.Log.Logger import qualified System.Log.Logger as L +import System.Random -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -108,10 +113,15 @@ data LanguageContextData config = , resWorkspaceFolders :: ![WorkspaceFolder] , resProgressData :: !ProgressData , resPendingResponses :: !ResponseMap + , resRegistrations :: !RegistrationMap , resLspId :: !Int } type ResponseMap = IxMap LspId (Product SMethod ServerResponseHandler) +type RegistrationMap = IxMap SMethod (Product RegistrationId RegistrationHandler) +-- type RegistrationMap = IxMap RegistrationId (Product SMethod RegistrationHandler) + +newtype RegistrationHandler (m :: Method FromClient t) = RegistrationHandler (ClientMessage m -> ClientResponseHandler m -> IO ()) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -258,7 +268,18 @@ data LspFuncs c = -- precentage complete. -- -- @since 0.10.0.0 + , registerDynamically :: !(forall m. SClientMethod m + -> RegistrationOptions m + -> (ClientMessage m -> ClientResponseHandler m -> IO ()) + -> IO (Maybe (RegistrationId m))) + -- ^ Returns 'Nothing' if the client does not support dynamic registration for the specified method } + +newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text + +instance IxOrd RegistrationId where + type Base RegistrationId = Text + toBase (RegistrationId t) = t -- | Contains all the callbacks to use for initialized the language server. -- it is parameterized over a config type variable representing the type for the @@ -337,14 +358,19 @@ nop :: Maybe (b -> LspM config ()) nop = Nothing handlerMap :: (Show config) => SClientMethod m -> ClientMessage m -> LspM config () -handlerMap c = case c of - SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) c - SWorkspaceDidChangeConfiguration -> hh (Just handleConfigChange) c - STextDocumentDidOpen -> hh (Just $ vfsFunc openVFS) c - STextDocumentDidChange -> hh (Just $ vfsFunc changeFromClientVFS) c - STextDocumentDidClose -> hh (Just $ vfsFunc closeVFS) c - SWorkDoneProgressCancel -> hh (Just progressCancelHandler) c - _ -> hh nop c +handlerMap c msg = do + -- First check to see if we have any dynamically registered handlers and call + -- their handlers + regHandlers <- readData resRegistrations + + case c of + SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) c msg + SWorkspaceDidChangeConfiguration -> hh (Just handleConfigChange) c msg + STextDocumentDidOpen -> hh (Just $ vfsFunc openVFS) c msg + STextDocumentDidChange -> hh (Just $ vfsFunc changeFromClientVFS) c msg + STextDocumentDidClose -> hh (Just $ vfsFunc closeVFS) c msg + SWorkDoneProgressCancel -> hh (Just progressCancelHandler) c msg + _ -> hh nop c msg -- --------------------------------------------------------------------- @@ -586,7 +612,16 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r initialConfigRes = onInitialConfiguration req initialConfig = either (const Nothing) Just initialConfigRes - tvarCtx <- newTVarIO $ LanguageContextData (VFSData vfs mempty) mempty initialConfig wfs defaultProgressData emptyIxMap 0 + tvarCtx <- newTVarIO $ + LanguageContextData + (VFSData vfs mempty) + mempty + initialConfig + wfs + defaultProgressData + emptyIxMap + emptyIxMap + 0 -- Launch the given process once the project root directory has been set let lspFuncs = LspFuncs (params ^. J.capabilities) @@ -604,6 +639,7 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r (getWfs tvarCtx) withProgressFunc withIndefiniteProgressFunc + (\a b c -> flip runReaderT env $ registerDynamicallyFunc (params ^. J.capabilities) a b c) env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx withProgressFunc :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a @@ -634,6 +670,70 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r return $ Just env +registerDynamicallyFunc :: J.ClientCapabilities +-- It's not limited to notifications though, its notifications + requests + -> SClientMethod (m :: Method FromClient t) + -> RegistrationOptions m + -> (ClientMessage m -> ClientResponseHandler m -> IO ()) + -> LspM config (Maybe (RegistrationId m)) +registerDynamicallyFunc clientCaps method regOpts f + -- First, check to see if the client supports dynamic registration on this method + | dynamicSupported = do + uuid <- liftIO $ UUID.toText <$> getStdRandom random + let registration = J.Registration uuid method regOpts + params = J.RegistrationParams (J.List [J.SomeRegistration registration]) + regId = RegistrationId uuid + + -- TODO: handle the scenario where this returns an error + mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () + modifyData $ \ctx -> + let oldRegs = resRegistrations ctx + pair = Pair method (RegistrationHandler f) + newRegs = fromMaybe (error "Registration UUID already exists!") $ + insertIxMap regId pair oldRegs + in ctx { resRegistrations = (id oldRegs) } + + pure (Just regId) + | otherwise = pure Nothing + where + -- Also I'm thinking we should move this function to somewhere in messages.hs so + -- we don't forget to update it when adding new methods... + capDyn :: J.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool + capDyn (Just x) = fromMaybe False $ x ^. J.dynamicRegistration + capDyn Nothing = False + -- | Checks if client capabilities declares that the method supports dynamic registration + dynamicSupported = case method of + SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just + SWorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just + SWorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just + SWorkspaceExecuteCommand -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just + STextDocumentDidOpen -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentDidChange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentDidClose -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentCompletion -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just + STextDocumentHover -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just + STextDocumentSignatureHelp -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just + STextDocumentDeclaration -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just + STextDocumentDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just + STextDocumentTypeDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just + STextDocumentImplementation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just + STextDocumentReferences -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just + STextDocumentDocumentHighlight -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just + STextDocumentDocumentSymbol -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just + STextDocumentCodeAction -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just + STextDocumentCodeLens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just + STextDocumentDocumentLink -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just + STextDocumentDocumentColor -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + STextDocumentColorPresentation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + STextDocumentFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just + STextDocumentRangeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just + STextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just + STextDocumentRename -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just + STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just + STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just + _ -> False + + -------------------------------------------------------------------------------- -- PROGRESS -------------------------------------------------------------------------------- diff --git a/stack-8.4.4.yaml b/stack-8.4.4.yaml index c2433c7e7..0f8a08904 100644 --- a/stack-8.4.4.yaml +++ b/stack-8.4.4.yaml @@ -6,6 +6,7 @@ packages: extra-deps: - rope-utf16-splay-0.3.1.0 +- some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 flags: {} extra-package-dbs: [] From 582daad56160962684e81f4f2c5b3830e27d47ba Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 20 Aug 2020 16:26:12 +0100 Subject: [PATCH 31/63] Forward on messages to dynamic handlers --- .../src/Language/Haskell/LSP/Types/Method.hs | 5 ++ src/Language/Haskell/LSP/Core.hs | 57 +++++++++++++++---- 2 files changed, 50 insertions(+), 12 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index c49eabdc4..6540597fd 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -12,6 +12,7 @@ module Language.Haskell.LSP.Types.Method where import qualified Data.Aeson as A import Data.Aeson.Types +import Data.IxMap import Data.Text (Text) import Language.Haskell.LSP.Types.Utils import Data.Function (on) @@ -382,3 +383,7 @@ instance A.ToJSON (SMethod m) where toJSON SCancelRequest = A.String "$/cancelRequest" -- Custom toJSON (SCustomMethod m) = A.String m + +instance IxOrd SMethod where + type Base SMethod = A.Value + toBase = A.toJSON diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index ca2ef7e14..74b069424 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -49,7 +49,6 @@ import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad import Control.Applicative -import Data.Functor.Product import Control.Monad.IO.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Reader @@ -60,6 +59,8 @@ import qualified Data.Aeson.Types as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B import Data.Default +import Data.Functor.Compose +import Data.Functor.Product import Data.IxMap import qualified Data.Dependent.Map as DMap import Data.Dependent.Map (DMap) @@ -113,15 +114,16 @@ data LanguageContextData config = , resWorkspaceFolders :: ![WorkspaceFolder] , resProgressData :: !ProgressData , resPendingResponses :: !ResponseMap - , resRegistrations :: !RegistrationMap + , resRegistrationsNot :: !(RegistrationMap Notification) + , resRegistrationsReq :: !(RegistrationMap Request) , resLspId :: !Int } type ResponseMap = IxMap LspId (Product SMethod ServerResponseHandler) -type RegistrationMap = IxMap SMethod (Product RegistrationId RegistrationHandler) +type RegistrationMap t = IxMap SMethod (Compose [] (Product RegistrationId (RegistrationHandler t))) -- type RegistrationMap = IxMap RegistrationId (Product SMethod RegistrationHandler) -newtype RegistrationHandler (m :: Method FromClient t) = RegistrationHandler (ClientMessage m -> ClientResponseHandler m -> IO ()) +newtype RegistrationHandler t (m :: Method FromClient t) = RegistrationHandler (ClientMessage m -> ClientResponseHandler m -> IO ()) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -361,7 +363,23 @@ handlerMap :: (Show config) => SClientMethod m -> ClientMessage m -> LspM config handlerMap c msg = do -- First check to see if we have any dynamically registered handlers and call -- their handlers - regHandlers <- readData resRegistrations + regsReq <- readData resRegistrationsReq + regsNot <- readData resRegistrationsNot + case splitClientMethod c of + IsClientReq -> + case lookupIxMap c regsReq of + -- TODO: If one request handles it, stop here and break out so we don't send back multiple responses? + Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler f)) -> do + respH <- mkClientResponseHandler c msg + liftIO $ f msg respH + Nothing -> pure () + IsClientNot -> + case lookupIxMap c regsNot of + Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler f)) -> do + respH <- mkClientResponseHandler c msg + liftIO $ f msg respH + Nothing -> pure () + _ -> pure () case c of SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) c msg @@ -621,6 +639,7 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r defaultProgressData emptyIxMap emptyIxMap + emptyIxMap 0 -- Launch the given process once the project root directory has been set @@ -685,13 +704,27 @@ registerDynamicallyFunc clientCaps method regOpts f regId = RegistrationId uuid -- TODO: handle the scenario where this returns an error - mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () - modifyData $ \ctx -> - let oldRegs = resRegistrations ctx - pair = Pair method (RegistrationHandler f) - newRegs = fromMaybe (error "Registration UUID already exists!") $ - insertIxMap regId pair oldRegs - in ctx { resRegistrations = (id oldRegs) } + _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () + + case splitClientMethod method of + IsClientNot -> modifyData $ \ctx -> + let oldRegs = resRegistrationsNot ctx + pair = Compose [Pair regId (RegistrationHandler f)] + newRegs = fromMaybe (error "TODO") $ + insertIxMap method pair oldRegs + in ctx { resRegistrationsNot = newRegs } + IsClientReq -> modifyData $ \ctx -> + let oldRegs = resRegistrationsReq ctx + pair = Compose [Pair regId (RegistrationHandler f)] + newRegs = fromMaybe (error "TODO") $ + insertIxMap method pair oldRegs + in ctx { resRegistrationsReq = newRegs } + _ -> pure () + -- let oldRegs = resRegistrationsReq ctx + -- pair = Compose [Pair regId (RegistrationHandler f)] + -- newRegs = fromMaybe (error "Registration UUID already exists!") $ + -- insertIxMap method pair oldRegs + -- in ctx { resRegistrationsReqs = oldRegs } pure (Just regId) | otherwise = pure Nothing From b8c568dc8f4056f72fa40005445f18a6381c2802 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 20 Aug 2020 16:59:18 +0100 Subject: [PATCH 32/63] Add dynamic reg example to lsp-hello --- example/Main.hs | 57 +++++++++----------------------- src/Language/Haskell/LSP/Core.hs | 28 ++++++++-------- 2 files changed, 30 insertions(+), 55 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index 168043038..bbc3a8ae4 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -8,6 +8,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} {- | This is an example language server built with haskell-lsp using a 'Reactor' @@ -199,40 +200,8 @@ lspHandlers rin method = handle :: J.SMethod m -> Maybe (J.ClientMessage m -> J.ResponseHandlerFunc m -> R () ()) handle J.SInitialized = Just $ \_msg () -> do liftIO $ U.logm "Processing the Initialized notification" - -- Server is ready, register any specific capabilities we need - - {- - Example: - { - "method": "client/registerCapability", - "params": { - "registrations": [ - { - "id": "79eee87c-c409-4664-8102-e03263673f6f", - "method": "textDocument/willSaveWaitUntil", - "registerOptions": { - "documentSelector": [ - { "language": "javascript" } - ] - } - } - ] - } - } - -} - let registration = J.Registration "code-lens" - J.STextDocumentCodeLens - (J.CodeLensRegistrationOptions - Nothing - Nothing - (Just False)) - regParams = J.RegistrationParams (J.List [J.SomeRegistration registration]) - void $ reactorSendReq J.SClientRegisterCapability regParams $ \_lid res -> - case res of - Left e -> liftIO $ U.logs $ "Got an error: " ++ show e - Right J.Empty -> liftIO $ U.logm "Got a response for registering WorkspaceExecuteCommand" - - -- example of showMessageRequest + + -- We're initialized! Lets send a showMessageRequest now let params = J.ShowMessageRequestParams J.MtWarning "What's your favourite language extension?" @@ -241,8 +210,19 @@ handle J.SInitialized = Just $ \_msg () -> do void $ reactorSendReq J.SWindowShowMessageRequest params $ \_lid res -> case res of Left e -> liftIO $ U.logs $ "Got an error: " ++ show e - Right _ -> reactorSendNot J.SWindowShowMessage - (J.ShowMessageParams J.MtInfo "Excellent choice") + Right _ -> do + reactorSendNot J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") + + -- We can dynamically register a capability once the user accepts it + reactorSendNot J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") + + Core.LspFuncs { Core.registerDynamically = registerDynamically } <- ask + let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) + void $ liftIO $ registerDynamically J.STextDocumentCodeLens regOpts $ \_req responder -> do + liftIO $ U.logs "Processing a textDocument/codeLens request" + let cmd = J.Command "Say hello" "lsp-hello-command" Nothing + rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] + liftIO $ responder (Right rsp) handle J.STextDocumentDidOpen = Just $ \msg () -> do let doc = msg ^. J.params . J.textDocument . J.uri @@ -325,11 +305,6 @@ handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do reactorSendNot J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "I was told to execute a command") -handle J.STextDocumentCodeLens = Just $ \_req responder -> do - liftIO $ U.logs "Processing a textDocument/codeLens request" - let cmd = J.Command "Say hello" "lsp-hello-command" Nothing - rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] - liftIO $ responder (Right rsp) handle _ = Nothing diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 74b069424..2d1b3395e 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -123,7 +123,7 @@ type ResponseMap = IxMap LspId (Product SMethod ServerResponseHandler) type RegistrationMap t = IxMap SMethod (Compose [] (Product RegistrationId (RegistrationHandler t))) -- type RegistrationMap = IxMap RegistrationId (Product SMethod RegistrationHandler) -newtype RegistrationHandler t (m :: Method FromClient t) = RegistrationHandler (ClientMessage m -> ClientResponseHandler m -> IO ()) +newtype RegistrationHandler t (m :: Method FromClient t) = RegistrationHandler (ClientMessage m -> ResponseHandlerFunc m -> IO ()) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -266,13 +266,13 @@ data LspFuncs c = -- @since 0.10.0.0 , withIndefiniteProgress :: !(forall a . Text -> ProgressCancellable -> IO a -> IO a) - -- ^ Same as 'withProgress', but for processes that do not report the - -- precentage complete. - -- - -- @since 0.10.0.0 - , registerDynamically :: !(forall m. SClientMethod m + -- ^ Same as 'withProgress', but for processes that do not report the + -- precentage complete. + -- + -- @since 0.10.0.0 + , registerDynamically :: !(forall t m. SMethod (m :: Method FromClient t) -> RegistrationOptions m - -> (ClientMessage m -> ClientResponseHandler m -> IO ()) + -> (ClientMessage m -> ResponseHandlerFunc m -> IO ()) -> IO (Maybe (RegistrationId m))) -- ^ Returns 'Nothing' if the client does not support dynamic registration for the specified method } @@ -365,21 +365,21 @@ handlerMap c msg = do -- their handlers regsReq <- readData resRegistrationsReq regsNot <- readData resRegistrationsNot - case splitClientMethod c of + ~() <- case splitClientMethod c of IsClientReq -> case lookupIxMap c regsReq of -- TODO: If one request handles it, stop here and break out so we don't send back multiple responses? Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler f)) -> do - respH <- mkClientResponseHandler c msg + ClientResponseHandler respH <- mkClientResponseHandler c msg liftIO $ f msg respH Nothing -> pure () IsClientNot -> case lookupIxMap c regsNot of Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler f)) -> do - respH <- mkClientResponseHandler c msg + ClientResponseHandler respH <- mkClientResponseHandler c msg liftIO $ f msg respH Nothing -> pure () - _ -> pure () + IsClientEither -> pure () case c of SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) c msg @@ -693,7 +693,7 @@ registerDynamicallyFunc :: J.ClientCapabilities -- It's not limited to notifications though, its notifications + requests -> SClientMethod (m :: Method FromClient t) -> RegistrationOptions m - -> (ClientMessage m -> ClientResponseHandler m -> IO ()) + -> (ClientMessage m -> ResponseHandlerFunc m -> IO ()) -> LspM config (Maybe (RegistrationId m)) registerDynamicallyFunc clientCaps method regOpts f -- First, check to see if the client supports dynamic registration on this method @@ -706,7 +706,7 @@ registerDynamicallyFunc clientCaps method regOpts f -- TODO: handle the scenario where this returns an error _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () - case splitClientMethod method of + ~() <- case splitClientMethod method of IsClientNot -> modifyData $ \ctx -> let oldRegs = resRegistrationsNot ctx pair = Compose [Pair regId (RegistrationHandler f)] @@ -719,7 +719,7 @@ registerDynamicallyFunc clientCaps method regOpts f newRegs = fromMaybe (error "TODO") $ insertIxMap method pair oldRegs in ctx { resRegistrationsReq = newRegs } - _ -> pure () + IsClientEither -> pure () -- let oldRegs = resRegistrationsReq ctx -- pair = Compose [Pair regId (RegistrationHandler f)] -- newRegs = fromMaybe (error "Registration UUID already exists!") $ From 90757e56e66964f368a6c9f81b53bbf3ab4ae020 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 24 Aug 2020 16:44:06 +0100 Subject: [PATCH 33/63] Rework Handlers to be one type family --- example/Main.hs | 41 +++-- .../src/Language/Haskell/LSP/Types/Message.hs | 14 +- src/Language/Haskell/LSP/Core.hs | 155 ++++++++---------- 3 files changed, 105 insertions(+), 105 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index bbc3a8ae4..b8e2da7ac 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -116,10 +116,11 @@ lspOptions = def { Core.textDocumentSync = Just syncOptions -- LSP client, so they can be sent to the backend compiler one at a time, and a -- reply sent. -data ReactorInput = forall t (m :: J.Method 'J.FromClient t). - ReactorInput (J.SMethod m) - (J.ClientMessage m) - (J.ResponseHandlerFunc m) +data ReactorInput + = forall (m :: J.Method 'J.FromClient 'J.Request). + ReactorInputReq (J.SMethod m) (J.RequestMessage m) (Either J.ResponseError (J.ResponseParams m) -> IO ()) + | forall (m :: J.Method 'J.FromClient 'J.Notification). + ReactorInputNot (J.SMethod m) (J.NotificationMessage m) -- --------------------------------------------------------------------- @@ -182,23 +183,33 @@ reactor :: Core.LspFuncs () -> TChan ReactorInput -> IO () reactor lf inp = do liftIO $ U.logs "reactor:entered" flip runReaderT lf $ forever $ do - ReactorInput method msg responder <- (liftIO $ atomically $ readTChan inp) - case handle method of - Just f -> f msg responder - Nothing -> pure () + reactorInput <- liftIO $ atomically $ readTChan inp + case reactorInput of + ReactorInputReq method msg responder -> + case handle method of + Just f -> f msg responder + Nothing -> pure () + ReactorInputNot method msg -> + case handle method of + Just f -> f msg + Nothing -> pure () -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as -- input into the reactor lspHandlers :: TChan ReactorInput -> Core.Handlers lspHandlers rin method = case handle method of - Just _ -> Just $ Core.Handler $ \clientMsg (Core.ClientResponseHandler responder) -> - atomically $ writeTChan rin (ReactorInput method clientMsg responder) + Just _ -> case J.splitClientMethod method of + J.IsClientReq -> Just $ \clientMsg responder -> + atomically $ writeTChan rin (ReactorInputReq method clientMsg responder) + J.IsClientNot -> Just $ \clientMsg -> + atomically $ writeTChan rin (ReactorInputNot method clientMsg) + J.IsClientEither -> error "TODO???" Nothing -> Nothing -- | Where the actual logic resides for handling requests and notifications. -handle :: J.SMethod m -> Maybe (J.ClientMessage m -> J.ResponseHandlerFunc m -> R () ()) -handle J.SInitialized = Just $ \_msg () -> do +handle :: J.SMethod m -> Maybe (J.BaseHandler m (R () ())) +handle J.SInitialized = Just $ \_msg -> do liftIO $ U.logm "Processing the Initialized notification" -- We're initialized! Lets send a showMessageRequest now @@ -224,13 +235,13 @@ handle J.SInitialized = Just $ \_msg () -> do rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] liftIO $ responder (Right rsp) -handle J.STextDocumentDidOpen = Just $ \msg () -> do +handle J.STextDocumentDidOpen = Just $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc liftIO $ U.logs $ "Processing DidOpenTextDocument for: " ++ show fileName sendDiagnostics (J.toNormalizedUri doc) (Just 0) -handle J.STextDocumentDidChange = Just $ \msg () -> do +handle J.STextDocumentDidChange = Just $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri @@ -244,7 +255,7 @@ handle J.STextDocumentDidChange = Just $ \msg () -> do Nothing -> do liftIO $ U.logs $ "Didn't find anything in the VFS for: " ++ show doc -handle J.STextDocumentDidSave = Just $ \msg () -> do +handle J.STextDocumentDidSave = Just $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc liftIO $ U.logs $ "Processing DidSaveTextDocument for: " ++ show fileName diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 2ee89b3ec..77361034a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -380,7 +380,19 @@ type family BaseMessage (t :: MethodType) :: Method p t -> Type where BaseMessage Request = RequestMessage BaseMessage Notification = NotificationMessage -type HandlerFunc a = Either ResponseError a -> IO () +-- | The type of a handler that handles requests and notifications coming in +-- from the server or client +type family Handler m :: Type where + Handler (m :: Method p t) = BaseHandler m (IO ()) + +-- | Version of 'Handler' that can be used to construct arbitrary functions +-- taking in the required handler arguments +type family BaseHandler (m :: Method p t) a :: Type where + BaseHandler (m :: Method p t) a = BaseHandler' t m a + +type family BaseHandler' (t :: MethodType) (m :: Method p t) (a :: Type) :: Type where + BaseHandler' Request m a = RequestMessage m -> (Either ResponseError (ResponseParams m) -> IO ()) -> a + BaseHandler' Notification m a = NotificationMessage m -> a -- Some helpful type synonyms type ClientMessage (m :: Method FromClient t) = Message m diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 2d1b3395e..521b81989 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -27,11 +27,9 @@ module Language.Haskell.LSP.Core ( , Progress(..) , ProgressCancellable(..) , ProgressCancelledException - , Handlers(..) + , Handlers , RegistrationId , Options(..) - , ClientRequestHandler(..) - , ClientNotificationHandler(..) , ServerResponseHandler(..) , makeResponseMessage , makeResponseError @@ -120,10 +118,9 @@ data LanguageContextData config = } type ResponseMap = IxMap LspId (Product SMethod ServerResponseHandler) -type RegistrationMap t = IxMap SMethod (Compose [] (Product RegistrationId (RegistrationHandler t))) --- type RegistrationMap = IxMap RegistrationId (Product SMethod RegistrationHandler) +type RegistrationMap t = DMap SMethod (Compose [] (Product RegistrationId (RegistrationHandler t))) -newtype RegistrationHandler t (m :: Method FromClient t) = RegistrationHandler (ClientMessage m -> ResponseHandlerFunc m -> IO ()) +newtype RegistrationHandler t (m :: Method FromClient t) = RegistrationHandler (Handler m) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -272,7 +269,7 @@ data LspFuncs c = -- @since 0.10.0.0 , registerDynamically :: !(forall t m. SMethod (m :: Method FromClient t) -> RegistrationOptions m - -> (ClientMessage m -> ResponseHandlerFunc m -> IO ()) + -> Handler m -> IO (Maybe (RegistrationId m))) -- ^ Returns 'Nothing' if the client does not support dynamic registration for the specified method } @@ -305,7 +302,7 @@ data InitializeCallbacks config = } newtype ServerResponseHandler (m :: Method FromServer Request) - = ServerResponseHandler (HandlerFunc (ResponseParams m)) + = ServerResponseHandler (Either ResponseError (ResponseParams m) -> IO ()) -- | Return value signals if response handler was inserted succesfully -- Might fail if the id was already in the map @@ -339,91 +336,77 @@ mkSendReqFunc m params resHandler = do IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg return reqId -newtype ClientRequestHandler (m :: Method FromClient Request) - = ClientRequestHandler - { runRequestHandler :: RequestMessage m -> HandlerFunc (ResponseParams m) -> IO () - } - -newtype ClientNotificationHandler (m :: Method FromClient Notification) - = ClientNotificationHandler - { runNotificationHandler :: NotificationMessage m -> IO () - } - -data Handlers - = Handlers - { requestHandlers :: DMap SMethod ClientRequestHandler - , notificationHandlers :: DMap SMethod ClientNotificationHandler - } +type Handlers = forall t (m :: Method FromClient t). (SMethod m -> Maybe (Handler m)) -- --------------------------------------------------------------------- nop :: Maybe (b -> LspM config ()) nop = Nothing handlerMap :: (Show config) => SClientMethod m -> ClientMessage m -> LspM config () -handlerMap c msg = do +handlerMap m msg = do -- First check to see if we have any dynamically registered handlers and call -- their handlers - regsReq <- readData resRegistrationsReq - regsNot <- readData resRegistrationsNot - ~() <- case splitClientMethod c of + sf <- asks resSendMessage + dynReqHandlers <- readData resRegistrationsReq -- :: LspM config (RegistrationMap Request) + dynNotHandlers <- readData resRegistrationsNot + ~() <- case splitClientMethod m of IsClientReq -> - case lookupIxMap c regsReq of + case DMap.lookup m dynReqHandlers of -- TODO: If one request handles it, stop here and break out so we don't send back multiple responses? - Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler f)) -> do - ClientResponseHandler respH <- mkClientResponseHandler c msg - liftIO $ f msg respH + Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler h)) -> + liftIO $ h msg (mkClientResponseCallback sf msg) Nothing -> pure () IsClientNot -> - case lookupIxMap c regsNot of - Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler f)) -> do - ClientResponseHandler respH <- mkClientResponseHandler c msg - liftIO $ f msg respH + case DMap.lookup m dynNotHandlers of + Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler h)) -> + liftIO $ h msg Nothing -> pure () IsClientEither -> pure () - case c of - SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) c msg - SWorkspaceDidChangeConfiguration -> hh (Just handleConfigChange) c msg - STextDocumentDidOpen -> hh (Just $ vfsFunc openVFS) c msg - STextDocumentDidChange -> hh (Just $ vfsFunc changeFromClientVFS) c msg - STextDocumentDidClose -> hh (Just $ vfsFunc closeVFS) c msg - SWorkDoneProgressCancel -> hh (Just progressCancelHandler) c msg - _ -> hh nop c msg + case m of + SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) m msg + SWorkspaceDidChangeConfiguration -> hh (Just handleConfigChange) m msg + STextDocumentDidOpen -> hh (Just $ vfsFunc openVFS) m msg + STextDocumentDidChange -> hh (Just $ vfsFunc changeFromClientVFS) m msg + STextDocumentDidClose -> hh (Just $ vfsFunc closeVFS) m msg + SWorkDoneProgressCancel -> hh (Just progressCancelHandler) m msg + _ -> hh nop m msg -- --------------------------------------------------------------------- -mkClientResponseHandler :: (FromServerMessage -> IO ()) -> RequestMessage (m :: Method FromClient Request) -> HandlerFunc (ResponseParams m) -mkClientResponseHandler sf req (Left err) = sf $ FromServerRsp (req ^. J.method) $ makeResponseError (req ^. J.id) err -mkClientResponseHandler sf req (Right rsp) = sf $ FromServerRsp (req ^. J.method) $ makeResponseMessage (req ^. J.id) rsp +-- | Makes the callback function passed to a 'Handler' +mkClientResponseCallback :: (FromServerMessage -> IO ()) -> RequestMessage (m :: Method FromClient Request) -> ((Either ResponseError (ResponseParams m)) -> IO ()) +mkClientResponseCallback sf req (Left err) = sf $ FromServerRsp (req ^. J.method) $ makeResponseError (req ^. J.id) err +mkClientResponseCallback sf req (Right rsp) = sf $ FromServerRsp (req ^. J.method) $ makeResponseMessage (req ^. J.id) rsp -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop hh :: Maybe (ClientMessage m -> LspM config ()) -> SClientMethod m -> ClientMessage m -> LspM config () -hh mAction m req = do - maybe (return ()) (\f -> f req) mAction - Handlers{..} <- asks resHandlers +hh mAction m msg = do + maybe (return ()) (\f -> f msg) mAction + handlers <- asks resHandlers sf <- asks resSendMessage - let mkRspH :: forall m. RequestMessage (m :: Method FromClient Request) -> HandlerFunc (ResponseParams m) - mkRspH = mkClientResponseHandler sf - ~() <- case splitClientMethod m of - IsClientNot -> case DMap.lookup m notificationHandlers of - Just h -> liftIO $ runNotificationHandler h req + let mkRspCb :: forall m. RequestMessage (m :: Method FromClient Request) -> ((Either ResponseError (ResponseParams m)) -> IO ()) + mkRspCb = mkClientResponseCallback sf + mHandler = handlers m + case splitClientMethod m of + IsClientNot -> case mHandler of + Just h -> liftIO $ h msg Nothing - | SExit <- m -> liftIO $ runNotificationHandler exitNotificationHandler req + | SExit <- m -> liftIO $ exitNotificationHandler msg | otherwise -> reportMissingHandler - IsClientReq -> case DMap.lookup m requestHandlers of - Just h -> liftIO $ runRequestHandler h req $ mkRspH req + IsClientReq -> case mHandler of + Just h -> liftIO $ h msg (mkRspCb msg) Nothing - | SShutdown <- m -> liftIO $ runRequestHandler shutdownRequestHandler req $ mkRspH req + | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) | otherwise -> reportMissingHandler - IsClientEither -> case req of - NotMess not -> case DMap.lookup m notificationHandlers of - Just h -> liftIO $ runNotificationHandler h not + IsClientEither -> case msg of + NotMess noti -> case mHandler of + Just h -> liftIO $ h noti Nothing -> reportMissingHandler - ReqMess req -> case DMap.lookup m requestHandlers of - Just h -> liftIO $ runRequestHandler h req $ mkRspH req + ReqMess req -> case mHandler of + Just h -> liftIO $ h req (mkRspCb req) Nothing -> reportMissingHandler - pure () where -- '$/' notifications should/could be ignored by server. -- Don't log errors in that case. @@ -432,8 +415,8 @@ hh mAction m req = do reportMissingHandler | isOptionalNotification m = return () | otherwise = do - let msg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m] - sendErrorLog msg + let errorMsg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m] + sendErrorLog errorMsg isOptionalNotification (SCustomMethod method) | "$/" `T.isPrefixOf` method = True isOptionalNotification _ = False @@ -638,8 +621,8 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r wfs defaultProgressData emptyIxMap - emptyIxMap - emptyIxMap + mempty + mempty 0 -- Launch the given process once the project root directory has been set @@ -693,7 +676,7 @@ registerDynamicallyFunc :: J.ClientCapabilities -- It's not limited to notifications though, its notifications + requests -> SClientMethod (m :: Method FromClient t) -> RegistrationOptions m - -> (ClientMessage m -> ResponseHandlerFunc m -> IO ()) + -> Handler m -> LspM config (Maybe (RegistrationId m)) registerDynamicallyFunc clientCaps method regOpts f -- First, check to see if the client supports dynamic registration on this method @@ -707,18 +690,15 @@ registerDynamicallyFunc clientCaps method regOpts f _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () ~() <- case splitClientMethod method of - IsClientNot -> modifyData $ \ctx -> - let oldRegs = resRegistrationsNot ctx - pair = Compose [Pair regId (RegistrationHandler f)] - newRegs = fromMaybe (error "TODO") $ - insertIxMap method pair oldRegs - in ctx { resRegistrationsNot = newRegs } - IsClientReq -> modifyData $ \ctx -> - let oldRegs = resRegistrationsReq ctx - pair = Compose [Pair regId (RegistrationHandler f)] - newRegs = fromMaybe (error "TODO") $ - insertIxMap method pair oldRegs - in ctx { resRegistrationsReq = newRegs } + IsClientNot -> modifyData $ \LanguageContextData{..} -> + let pair = Compose [Pair regId (RegistrationHandler f)] + newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair resRegistrationsNot + + in LanguageContextData { resRegistrationsNot = newRegs, .. } + IsClientReq -> modifyData $ \LanguageContextData{..} -> + let pair = Compose [Pair regId (RegistrationHandler f)] + newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair resRegistrationsReq + in LanguageContextData { resRegistrationsReq = newRegs, .. } IsClientEither -> pure () -- let oldRegs = resRegistrationsReq ctx -- pair = Compose [Pair regId (RegistrationHandler f)] @@ -895,10 +875,7 @@ serverCapabilities clientCaps o h = supported = Just . supported_b supported_b :: forall m. J.SClientMethod m -> Bool - supported_b m = case splitClientMethod m of - IsClientNot -> DMap.member m (notificationHandlers h) - IsClientReq -> DMap.member m (requestHandlers h) - IsClientEither -> False -- No capabilities for custom method + supported_b m = isJust (h m) singleton :: a -> [a] singleton x = [x] @@ -964,14 +941,14 @@ progressCancelHandler (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams Nothing -> return () Just cancelAction -> liftIO $ cancelAction -exitNotificationHandler :: ClientNotificationHandler J.Exit -exitNotificationHandler = ClientNotificationHandler $ \_ -> do +exitNotificationHandler :: Handler J.Exit +exitNotificationHandler = \_ -> do logm $ B.pack "haskell-lsp:Got exit, exiting" exitSuccess -- | Default Shutdown handler -shutdownRequestHandler :: ClientRequestHandler J.Shutdown -shutdownRequestHandler = ClientRequestHandler $ \_req k -> do +shutdownRequestHandler :: Handler J.Shutdown +shutdownRequestHandler = \_req k -> do k $ Right J.Empty -- --------------------------------------------------------------------- From cc2bee44bd1962c0daf97ff4b9643a3bdc881bb5 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 24 Aug 2020 17:12:37 +0100 Subject: [PATCH 34/63] Add simple demo server, rename existing one to Reactor --- .azure/linux-stack.yml | 2 +- .azure/macos-stack.yml | 2 +- .azure/windows-stack.yml | 2 +- README.md | 10 +++++----- example/{Main.hs => Reactor.hs} | 3 +-- example/Simple.hs | 25 +++++++++++++++++++++++++ haskell-lsp.cabal | 17 ++++++++++++++--- hie.yaml | 6 ++++-- 8 files changed, 52 insertions(+), 15 deletions(-) rename example/{Main.hs => Reactor.hs} (99%) create mode 100644 example/Simple.hs diff --git a/.azure/linux-stack.yml b/.azure/linux-stack.yml index b08e073e4..aad4722ef 100644 --- a/.azure/linux-stack.yml +++ b/.azure/linux-stack.yml @@ -59,7 +59,7 @@ jobs: displayName: Build `haskell-lsp` - bash: | source .azure/linux-stack.bashrc - stack build --stack-yaml $(YAML_FILE) :lsp-hello --flag haskell-lsp:demo + stack build --stack-yaml $(YAML_FILE) --flag haskell-lsp:demo displayName: Build language server example - bash: | source .azure/linux-stack.bashrc diff --git a/.azure/macos-stack.yml b/.azure/macos-stack.yml index 71fe8c4b6..22a66c466 100644 --- a/.azure/macos-stack.yml +++ b/.azure/macos-stack.yml @@ -60,7 +60,7 @@ jobs: displayName: Build `haskell-lsp` - bash: | source .azure/macos-stack.bashrc - stack build --stack-yaml $(YAML_FILE) :lsp-hello --flag haskell-lsp:demo + stack build --stack-yaml $(YAML_FILE) --flag haskell-lsp:demo displayName: Build language server example - bash: | source .azure/macos-stack.bashrc diff --git a/.azure/windows-stack.yml b/.azure/windows-stack.yml index 08a888709..028182974 100644 --- a/.azure/windows-stack.yml +++ b/.azure/windows-stack.yml @@ -61,7 +61,7 @@ jobs: displayName: Build `haskell-lsp` - bash: | source .azure/windows-stack.bashrc - stack build --stack-yaml $(YAML_FILE) :lsp-hello --flag haskell-lsp:demo + stack build --stack-yaml $(YAML_FILE) --flag haskell-lsp:demo displayName: Build language server example - bash: | source .azure/windows-stack.bashrc diff --git a/README.md b/README.md index 025e3f656..8ee255726 100644 --- a/README.md +++ b/README.md @@ -36,14 +36,14 @@ It can also be used with emacs, see https://github.com/emacs-lsp/lsp-haskell ## Using the example server - stack install :lsp-hello --flag haskell-lsp:demo + stack install :lsp-demo-reactor-server --flag haskell-lsp:demo -will generate a `lsp-hello` executable. +will generate a `:lsp-demo-reactor-server` executable. -Changing the server to be called in the [`vscode-hie-server`](https://github.com/alanz/vscode-hie-server/blob/master/hie-vscode.sh#L21) plugin from `hie` to -`lsp-hello` will run the example server instead of hie. +Changing the server executable in the [`vscode-haskell`](https://github.com/haskell/vscode-haskell) plugin to +`lsp-demo-reactor-server` to test it out. -Likewise, changing the executable in `lsp-haskell` for emacs. +Likewise, you can change the executable in `lsp-haskell` for emacs. ## Useful links diff --git a/example/Main.hs b/example/Reactor.hs similarity index 99% rename from example/Main.hs rename to example/Reactor.hs index b8e2da7ac..54f40e893 100644 --- a/example/Main.hs +++ b/example/Reactor.hs @@ -19,11 +19,10 @@ The `haskell-lsp` handlers then simply pass on all the requests and notifications onto the channel via 'ReactorInput's. To try out this server, install it with -> cabal install lsp-hello -fdemo +> cabal install lsp-demo-reactor-server -fdemo and plug it into your client of choice. -} module Main (main) where - import Control.Concurrent import Control.Concurrent.STM.TChan import qualified Control.Exception as E diff --git a/example/Simple.hs b/example/Simple.hs new file mode 100644 index 000000000..83109a345 --- /dev/null +++ b/example/Simple.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +import Data.Default +import Language.Haskell.LSP.Control +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Types + +handlers :: Handlers +handlers STextDocumentHover = Just $ \req responder -> do + let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover ms (Just range) + ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" + range = Range pos pos + responder (Right rsp) +handlers _ = Nothing + +initCallbacks = InitializeCallbacks + { onInitialConfiguration = const $ Right () + , onConfigurationChange = const $ Right () + , onStartup = const $ pure Nothing + } + +main = run initCallbacks handlers def diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index e61b7d944..3e17e7690 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -65,8 +65,8 @@ library default-language: Haskell2010 ghc-options: -Wall -fprint-explicit-kinds -executable lsp-hello - main-is: Main.hs +executable lsp-demo-reactor-server + main-is: Reactor.hs hs-source-dirs: example default-language: Haskell2010 ghc-options: -Wall @@ -93,8 +93,19 @@ executable lsp-hello if !flag(demo) buildable: False +executable lsp-demo-simple-server + main-is: Simple.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5 + , data-default + -- the package library. Comment this out if you want repl changes to propagate + , haskell-lsp + if !flag(demo) + buildable: False + flag demo { - description: Build the lsp-hello demo executable + description: Build the demo executables default: False } diff --git a/hie.yaml b/hie.yaml index 72220d7d0..bb01718f3 100644 --- a/hie.yaml +++ b/hie.yaml @@ -11,5 +11,7 @@ cradle: component: "haskell-lsp-types" - path: "./src" component: "haskell-lsp" - - path: "./example" - component: "lsp-hello" + - path: "./example/Reactor.hs" + component: "lsp-demo-reactor-server" + - path: "./example/Simple.hs" + component: "lsp-demo-simple-server" From 3ca4b30301678dd5b11b190b5b63e8a6849c4c90 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 24 Aug 2020 19:25:27 +0100 Subject: [PATCH 35/63] Add unregisterCapability --- example/Reactor.hs | 5 +- .../Haskell/LSP/Types/Registration.hs | 2 +- src/Language/Haskell/LSP/Core.hs | 102 +++++++++++------- 3 files changed, 66 insertions(+), 43 deletions(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 54f40e893..85fbeab96 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -226,9 +226,10 @@ handle J.SInitialized = Just $ \_msg -> do -- We can dynamically register a capability once the user accepts it reactorSendNot J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") - Core.LspFuncs { Core.registerDynamically = registerDynamically } <- ask + Core.LspFuncs { Core.registerCapability = registerCapability } <- ask let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) - void $ liftIO $ registerDynamically J.STextDocumentCodeLens regOpts $ \_req responder -> do + + void $ liftIO $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do liftIO $ U.logs "Processing a textDocument/codeLens request" let cmd = J.Command "Say hello" "lsp-hello-command" Nothing rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs index 76fccd3a0..dbbb01523 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Registration.hs @@ -170,7 +170,7 @@ data UnregistrationParams = { -- | This should correctly be named @unregistrations@. However changing this -- is a breaking change and needs to wait until we deliver a 4.x version -- of the specification. - _unregistrations :: List Unregistration + _unregisterations :: List Unregistration } deriving (Show, Eq) deriveJSON lspOptions ''UnregistrationParams diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 521b81989..dfdfaa7ff 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -28,7 +28,7 @@ module Language.Haskell.LSP.Core ( , ProgressCancellable(..) , ProgressCancelledException , Handlers - , RegistrationId + , RegistrationToken , Options(..) , ServerResponseHandler(..) , makeResponseMessage @@ -117,10 +117,15 @@ data LanguageContextData config = , resLspId :: !Int } -type ResponseMap = IxMap LspId (Product SMethod ServerResponseHandler) +type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) + type RegistrationMap t = DMap SMethod (Compose [] (Product RegistrationId (RegistrationHandler t))) -newtype RegistrationHandler t (m :: Method FromClient t) = RegistrationHandler (Handler m) +data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) +newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text + deriving Eq + +newtype RegistrationHandler (t :: MethodType) (m :: Method FromClient t) = RegistrationHandler (Handler m) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -267,18 +272,18 @@ data LspFuncs c = -- precentage complete. -- -- @since 0.10.0.0 - , registerDynamically :: !(forall t m. SMethod (m :: Method FromClient t) - -> RegistrationOptions m - -> Handler m - -> IO (Maybe (RegistrationId m))) - -- ^ Returns 'Nothing' if the client does not support dynamic registration for the specified method + , registerCapability :: !(forall t m. SMethod (m :: Method FromClient t) + -> RegistrationOptions m + -> Handler m + -> IO (Maybe (RegistrationToken m))) + -- ^ Sends a @client/registerCapability@ request and dynamically registers + -- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not + -- support dynamic registration for the specified method, otherwise a + -- 'RegistrationToken' which can be used to unregister it later + , unregisterCapability :: !(forall t (m :: Method FromClient t). RegistrationToken m -> IO ()) + -- ^ Sends a @client/unregisterCapability@ request and removes the handler + -- for that associated registration. } - -newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text - -instance IxOrd RegistrationId where - type Base RegistrationId = Text - toBase (RegistrationId t) = t -- | Contains all the callbacks to use for initialized the language server. -- it is parameterized over a config type variable representing the type for the @@ -301,12 +306,14 @@ data InitializeCallbacks config = -- that may be necesary for the server lifecycle. } -newtype ServerResponseHandler (m :: Method FromServer Request) - = ServerResponseHandler (Either ResponseError (ResponseParams m) -> IO ()) +-- | A function that a 'Handler' is passed that can be used to respond to a +-- request with either an error, or the response params. +newtype ServerResponseCallback (m :: Method FromServer Request) + = ServerResponseCallback (Either ResponseError (ResponseParams m) -> IO ()) -- | Return value signals if response handler was inserted succesfully -- Might fail if the id was already in the map -addResponseHandler :: LspId m -> (Product SMethod ServerResponseHandler) m -> LspM config Bool +addResponseHandler :: LspId m -> (Product SMethod ServerResponseCallback) m -> LspM config Bool addResponseHandler lid h = do stateData $ \ctx@LanguageContextData{resPendingResponses} -> case insertIxMap lid h resPendingResponses of @@ -327,7 +334,7 @@ mkSendReqFunc :: forall (m :: Method FromServer Request) config. -> LspM config (LspId m) mkSendReqFunc m params resHandler = do reqId <- IdInt <$> freshLspId - success <- addResponseHandler reqId (Pair m (ServerResponseHandler (resHandler reqId))) + success <- addResponseHandler reqId (Pair m (ServerResponseCallback (resHandler reqId))) unless success $ error "haskell-lsp: could not send FromServer request as id is reused" let msg = RequestMessage "2.0" reqId m params @@ -347,7 +354,7 @@ handlerMap m msg = do -- First check to see if we have any dynamically registered handlers and call -- their handlers sf <- asks resSendMessage - dynReqHandlers <- readData resRegistrationsReq -- :: LspM config (RegistrationMap Request) + dynReqHandlers <- readData resRegistrationsReq dynNotHandlers <- readData resRegistrationsNot ~() <- case splitClientMethod m of IsClientReq -> @@ -513,11 +520,11 @@ handleMessage jsonStr = do lift $ case msg of FromClientMess m mess -> pure $ handlerMap m mess - FromClientRsp (Pair (ServerResponseHandler f) (Const newMap)) res -> do + FromClientRsp (Pair (ServerResponseCallback f) (Const newMap)) res -> do modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap }) pure $ liftIO $ f (res ^. J.result) where - parser :: ResponseMap -> J.Value -> J.Parser (FromClientMessage' (Product ServerResponseHandler (Const ResponseMap))) + parser :: ResponseMap -> J.Value -> J.Parser (FromClientMessage' (Product ServerResponseCallback (Const ResponseMap))) parser rm = parseClientMessage $ \i -> let (mhandler, newMap) = pickFromIxMap i rm in (\(Pair m handler) -> (m,Pair handler (Const newMap))) <$> mhandler @@ -641,7 +648,8 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r (getWfs tvarCtx) withProgressFunc withIndefiniteProgressFunc - (\a b c -> flip runReaderT env $ registerDynamicallyFunc (params ^. J.capabilities) a b c) + (\a b c -> flip runReaderT env $ registerCapabilityFunc (params ^. J.capabilities) a b c) + (flip runReaderT env . unregisterCapabilityFunc) env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx withProgressFunc :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a @@ -672,13 +680,13 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r return $ Just env -registerDynamicallyFunc :: J.ClientCapabilities +registerCapabilityFunc :: J.ClientCapabilities -- It's not limited to notifications though, its notifications + requests -> SClientMethod (m :: Method FromClient t) -> RegistrationOptions m -> Handler m - -> LspM config (Maybe (RegistrationId m)) -registerDynamicallyFunc clientCaps method regOpts f + -> LspM config (Maybe (RegistrationToken m)) +registerCapabilityFunc clientCaps method regOpts f -- First, check to see if the client supports dynamic registration on this method | dynamicSupported = do uuid <- liftIO $ UUID.toText <$> getStdRandom random @@ -686,27 +694,22 @@ registerDynamicallyFunc clientCaps method regOpts f params = J.RegistrationParams (J.List [J.SomeRegistration registration]) regId = RegistrationId uuid - -- TODO: handle the scenario where this returns an error - _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () - ~() <- case splitClientMethod method of - IsClientNot -> modifyData $ \LanguageContextData{..} -> + IsClientNot -> modifyData $ \ctx -> let pair = Compose [Pair regId (RegistrationHandler f)] - newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair resRegistrationsNot + newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair (resRegistrationsNot ctx) - in LanguageContextData { resRegistrationsNot = newRegs, .. } - IsClientReq -> modifyData $ \LanguageContextData{..} -> + in ctx { resRegistrationsNot = newRegs } + IsClientReq -> modifyData $ \ctx -> let pair = Compose [Pair regId (RegistrationHandler f)] - newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair resRegistrationsReq - in LanguageContextData { resRegistrationsReq = newRegs, .. } + newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair (resRegistrationsReq ctx) + in ctx { resRegistrationsReq = newRegs } IsClientEither -> pure () - -- let oldRegs = resRegistrationsReq ctx - -- pair = Compose [Pair regId (RegistrationHandler f)] - -- newRegs = fromMaybe (error "Registration UUID already exists!") $ - -- insertIxMap method pair oldRegs - -- in ctx { resRegistrationsReqs = oldRegs } + + -- TODO: handle the scenario where this returns an error + _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () - pure (Just regId) + pure (Just (RegistrationToken method regId)) | otherwise = pure Nothing where -- Also I'm thinking we should move this function to somewhere in messages.hs so @@ -746,6 +749,25 @@ registerDynamicallyFunc clientCaps method regOpts f STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just _ -> False +unregisterCapabilityFunc :: RegistrationToken m -> LspM config () +unregisterCapabilityFunc (RegistrationToken m regId@(RegistrationId uuid)) = do + ~() <- case splitClientMethod m of + IsClientReq -> do + reqRegs <- readData resRegistrationsReq + let f (Compose xs) = Just $ Compose $ filter (\(Pair regId' _) -> regId /= regId') xs + newMap = DMap.update f m reqRegs + modifyData (\ctx -> ctx { resRegistrationsReq = newMap }) + IsClientNot -> do + notRegs <- readData resRegistrationsNot + let f (Compose xs) = Just $ Compose $ filter (\(Pair regId' _) -> regId /= regId') xs + newMap = DMap.update f m notRegs + modifyData (\ctx -> ctx { resRegistrationsNot = newMap }) + _ -> error "TODO???" + + + let unregistration = J.Unregistration uuid (J.SomeClientMethod m) + params = J.UnregistrationParams (J.List [unregistration]) + void $ mkSendReqFunc SClientUnregisterCapability params $ \_id _res -> pure () -------------------------------------------------------------------------------- -- PROGRESS From 1064dec625ce6de71b0779eb2d3feacf25f1f890 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 25 Aug 2020 11:01:07 +0100 Subject: [PATCH 36/63] Simplify Handler family further Rename ServerResponseHandler to ServerResponseCallback to avoid confusion --- .../src/Language/Haskell/LSP/Types/Message.hs | 30 +++++++++---------- .../src/Language/Haskell/LSP/Types/Method.hs | 5 ---- src/Language/Haskell/LSP/Core.hs | 1 - 3 files changed, 14 insertions(+), 22 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 77361034a..c6a16ba43 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -367,19 +367,9 @@ instance FromJSON (ResponseParams a) => FromJSON (ResponseMessage a) where return $ ResponseMessage _jsonrpc _id $ result -- --------------------------------------------------------------------- --- Helper Type Families +-- Handlers -- --------------------------------------------------------------------- --- | Map a method to the Request/Notification type with the correct --- payload -type family Message (m :: Method p t) :: Type where - Message (CustomMethod :: Method p t) = CustomMessage p t - Message (m :: Method p t) = BaseMessage t m - -type family BaseMessage (t :: MethodType) :: Method p t -> Type where - BaseMessage Request = RequestMessage - BaseMessage Notification = NotificationMessage - -- | The type of a handler that handles requests and notifications coming in -- from the server or client type family Handler m :: Type where @@ -387,12 +377,20 @@ type family Handler m :: Type where -- | Version of 'Handler' that can be used to construct arbitrary functions -- taking in the required handler arguments -type family BaseHandler (m :: Method p t) a :: Type where - BaseHandler (m :: Method p t) a = BaseHandler' t m a +type family BaseHandler (m :: Method p t) (a :: Type) :: Type where + BaseHandler (m :: Method p Request) a = RequestMessage m -> (Either ResponseError (ResponseParams m) -> IO ()) -> a + BaseHandler (m :: Method p Notification) a = NotificationMessage m -> a -type family BaseHandler' (t :: MethodType) (m :: Method p t) (a :: Type) :: Type where - BaseHandler' Request m a = RequestMessage m -> (Either ResponseError (ResponseParams m) -> IO ()) -> a - BaseHandler' Notification m a = NotificationMessage m -> a +-- --------------------------------------------------------------------- +-- Helper Type Families +-- --------------------------------------------------------------------- + +-- | Map a method to the Request/Notification type with the correct +-- payload +type family Message (m :: Method p t) :: Type where + Message (CustomMethod :: Method p t) = CustomMessage p t + Message (m :: Method p Request) = RequestMessage m + Message (m :: Method p Notification) = NotificationMessage m -- Some helpful type synonyms type ClientMessage (m :: Method FromClient t) = Message m diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index 6540597fd..c49eabdc4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -12,7 +12,6 @@ module Language.Haskell.LSP.Types.Method where import qualified Data.Aeson as A import Data.Aeson.Types -import Data.IxMap import Data.Text (Text) import Language.Haskell.LSP.Types.Utils import Data.Function (on) @@ -383,7 +382,3 @@ instance A.ToJSON (SMethod m) where toJSON SCancelRequest = A.String "$/cancelRequest" -- Custom toJSON (SCustomMethod m) = A.String m - -instance IxOrd SMethod where - type Base SMethod = A.Value - toBase = A.toJSON diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index dfdfaa7ff..2c95c7d30 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -30,7 +30,6 @@ module Language.Haskell.LSP.Core ( , Handlers , RegistrationToken , Options(..) - , ServerResponseHandler(..) , makeResponseMessage , makeResponseError , setupLogger From 278781417d58457f7d72fa2a220e0f608a2086a4 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 25 Aug 2020 11:45:00 +0100 Subject: [PATCH 37/63] Tidy up handerMap and handlers --- src/Language/Haskell/LSP/Core.hs | 195 ++++++++++++++++--------------- 1 file changed, 100 insertions(+), 95 deletions(-) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 2c95c7d30..80a61e287 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -56,7 +56,6 @@ import qualified Data.Aeson.Types as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B import Data.Default -import Data.Functor.Compose import Data.Functor.Product import Data.IxMap import qualified Data.Dependent.Map as DMap @@ -102,6 +101,10 @@ data LanguageContextEnv config = , resData :: !(TVar (LanguageContextData config)) } +-- | A mapping from methods to the static 'Handler's that should be used to +-- handle them when they come in from the client. +type Handlers = forall t (m :: Method FromClient t). (SMethod m -> Maybe (Handler m)) + -- | state used by the LSP dispatcher to manage the message loop data LanguageContextData config = LanguageContextData @@ -118,7 +121,7 @@ data LanguageContextData config = type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) -type RegistrationMap t = DMap SMethod (Compose [] (Product RegistrationId (RegistrationHandler t))) +type RegistrationMap t = DMap SMethod (Product RegistrationId (RegistrationHandler t)) data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text @@ -342,78 +345,67 @@ mkSendReqFunc m params resHandler = do IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg return reqId -type Handlers = forall t (m :: Method FromClient t). (SMethod m -> Maybe (Handler m)) - -- --------------------------------------------------------------------- -nop :: Maybe (b -> LspM config ()) -nop = Nothing -handlerMap :: (Show config) => SClientMethod m -> ClientMessage m -> LspM config () -handlerMap m msg = do - -- First check to see if we have any dynamically registered handlers and call - -- their handlers - sf <- asks resSendMessage - dynReqHandlers <- readData resRegistrationsReq - dynNotHandlers <- readData resRegistrationsNot - ~() <- case splitClientMethod m of - IsClientReq -> - case DMap.lookup m dynReqHandlers of - -- TODO: If one request handles it, stop here and break out so we don't send back multiple responses? - Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler h)) -> - liftIO $ h msg (mkClientResponseCallback sf msg) - Nothing -> pure () - IsClientNot -> - case DMap.lookup m dynNotHandlers of - Just (Compose regs) -> forM_ regs $ \(Pair _regId (RegistrationHandler h)) -> - liftIO $ h msg - Nothing -> pure () - IsClientEither -> pure () - +-- | Invokes the registered dynamic or static handlers for the given message and +-- method, as well as doing some bookkeeping. +handle :: (Show config) => SClientMethod m -> ClientMessage m -> LspM config () +handle m msg = case m of - SWorkspaceDidChangeWorkspaceFolders -> hh (Just updateWorkspaceFolders) m msg - SWorkspaceDidChangeConfiguration -> hh (Just handleConfigChange) m msg - STextDocumentDidOpen -> hh (Just $ vfsFunc openVFS) m msg - STextDocumentDidChange -> hh (Just $ vfsFunc changeFromClientVFS) m msg - STextDocumentDidClose -> hh (Just $ vfsFunc closeVFS) m msg - SWorkDoneProgressCancel -> hh (Just progressCancelHandler) m msg - _ -> hh nop m msg - --- --------------------------------------------------------------------- - --- | Makes the callback function passed to a 'Handler' -mkClientResponseCallback :: (FromServerMessage -> IO ()) -> RequestMessage (m :: Method FromClient Request) -> ((Either ResponseError (ResponseParams m)) -> IO ()) -mkClientResponseCallback sf req (Left err) = sf $ FromServerRsp (req ^. J.method) $ makeResponseError (req ^. J.id) err -mkClientResponseCallback sf req (Right rsp) = sf $ FromServerRsp (req ^. J.method) $ makeResponseMessage (req ^. J.id) rsp - --- | Adapter from the normal handlers exposed to the library users and the --- internal message loop -hh :: Maybe (ClientMessage m -> LspM config ()) -> SClientMethod m -> ClientMessage m -> LspM config () -hh mAction m msg = do + SWorkspaceDidChangeWorkspaceFolders -> handle' (Just updateWorkspaceFolders) m msg + SWorkspaceDidChangeConfiguration -> handle' (Just handleConfigChange) m msg + STextDocumentDidOpen -> handle' (Just $ vfsFunc openVFS) m msg + STextDocumentDidChange -> handle' (Just $ vfsFunc changeFromClientVFS) m msg + STextDocumentDidClose -> handle' (Just $ vfsFunc closeVFS) m msg + SWorkDoneProgressCancel -> handle' (Just progressCancelHandler) m msg + _ -> handle' Nothing m msg + + +handle' :: forall t (m :: Method FromClient t) config. + Maybe (ClientMessage m -> LspM config ()) + -- ^ An action to be run before invoking the handler, used for + -- bookkeeping stuff like the vfs etc. + -> SClientMethod m + -> ClientMessage m + -> LspM config () +handle' mAction m msg = do maybe (return ()) (\f -> f msg) mAction - handlers <- asks resHandlers + + dynReqHandlers <- readData resRegistrationsReq + dynNotHandlers <- readData resRegistrationsNot + staticHandlers <- asks resHandlers sf <- asks resSendMessage - let mkRspCb :: forall m. RequestMessage (m :: Method FromClient Request) -> ((Either ResponseError (ResponseParams m)) -> IO ()) - mkRspCb = mkClientResponseCallback sf - mHandler = handlers m + let mStaticHandler = staticHandlers m + case splitClientMethod m of - IsClientNot -> case mHandler of + IsClientNot -> case pickHandler dynNotHandlers mStaticHandler of Just h -> liftIO $ h msg Nothing | SExit <- m -> liftIO $ exitNotificationHandler msg | otherwise -> reportMissingHandler - IsClientReq -> case mHandler of - Just h -> liftIO $ h msg (mkRspCb msg) + + IsClientReq -> case pickHandler dynReqHandlers mStaticHandler of + Just h -> liftIO $ h msg (mkRspCb sf msg) Nothing - | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) + | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb sf msg) | otherwise -> reportMissingHandler + IsClientEither -> case msg of - NotMess noti -> case mHandler of + NotMess noti -> case pickHandler dynNotHandlers mStaticHandler of Just h -> liftIO $ h noti Nothing -> reportMissingHandler - ReqMess req -> case mHandler of - Just h -> liftIO $ h req (mkRspCb req) + ReqMess req -> case pickHandler dynReqHandlers mStaticHandler of + Just h -> liftIO $ h req (mkRspCb sf req) Nothing -> reportMissingHandler where + -- | Checks to see if there's a dynamic handler, and uses it in favour of the + -- static handler, if it exists. + pickHandler :: RegistrationMap t -> Maybe (Handler m) -> Maybe (Handler m) + pickHandler dynHandlerMap mStaticHandler = case (DMap.lookup m dynHandlerMap, mStaticHandler) of + (Just (Pair _ (RegistrationHandler h)), _) -> Just h + (Nothing, Just h) -> Just h + (Nothing, Nothing) -> Nothing + -- '$/' notifications should/could be ignored by server. -- Don't log errors in that case. -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. @@ -427,6 +419,16 @@ hh mAction m msg = do | "$/" `T.isPrefixOf` method = True isOptionalNotification _ = False + -- | Makes the callback function passed to a 'Handler' + mkRspCb :: (FromServerMessage -> IO ()) + -> RequestMessage (m1 :: Method FromClient Request) + -> ((Either ResponseError (ResponseParams m1)) + -> IO ()) + mkRspCb sf req (Left err) = sf $ + FromServerRsp (req ^. J.method) $ makeResponseError (req ^. J.id) err + mkRspCb sf req (Right rsp) = sf $ + FromServerRsp (req ^. J.method) $ makeResponseMessage (req ^. J.id) rsp + handleConfigChange :: DidChangeConfigurationNotification -> LspM config () handleConfigChange req = do parseConfig <- asks resParseConfig @@ -518,7 +520,7 @@ handleMessage jsonStr = do msg <- except $ J.parseEither (parser $ resPendingResponses ctx) val lift $ case msg of FromClientMess m mess -> - pure $ handlerMap m mess + pure $ handle m mess FromClientRsp (Pair (ServerResponseCallback f) (Const newMap)) res -> do modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap }) pure $ liftIO $ f (res ^. J.result) @@ -681,36 +683,42 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r registerCapabilityFunc :: J.ClientCapabilities -- It's not limited to notifications though, its notifications + requests - -> SClientMethod (m :: Method FromClient t) - -> RegistrationOptions m - -> Handler m - -> LspM config (Maybe (RegistrationToken m)) -registerCapabilityFunc clientCaps method regOpts f - -- First, check to see if the client supports dynamic registration on this method - | dynamicSupported = do - uuid <- liftIO $ UUID.toText <$> getStdRandom random - let registration = J.Registration uuid method regOpts - params = J.RegistrationParams (J.List [J.SomeRegistration registration]) - regId = RegistrationId uuid - - ~() <- case splitClientMethod method of - IsClientNot -> modifyData $ \ctx -> - let pair = Compose [Pair regId (RegistrationHandler f)] - newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair (resRegistrationsNot ctx) - - in ctx { resRegistrationsNot = newRegs } - IsClientReq -> modifyData $ \ctx -> - let pair = Compose [Pair regId (RegistrationHandler f)] - newRegs = DMap.insertWith (\(Compose xs) (Compose ys) -> Compose (xs <> ys)) method pair (resRegistrationsReq ctx) - in ctx { resRegistrationsReq = newRegs } - IsClientEither -> pure () - - -- TODO: handle the scenario where this returns an error - _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () - - pure (Just (RegistrationToken method regId)) - | otherwise = pure Nothing + -> SClientMethod (m :: Method FromClient t) + -> RegistrationOptions m + -> Handler m + -> LspM config (Maybe (RegistrationToken m)) +registerCapabilityFunc clientCaps method regOpts f = do + handlers <- asks resHandlers + let alreadyStaticallyRegistered = isJust $ handlers method + go alreadyStaticallyRegistered where + -- If the server has already registered statically, don't dynamically register + -- as per the spec + go True = pure Nothing + go False + -- First, check to see if the client supports dynamic registration on this method + | dynamicSupported = do + uuid <- liftIO $ UUID.toText <$> getStdRandom random + let registration = J.Registration uuid method regOpts + params = J.RegistrationParams (J.List [J.SomeRegistration registration]) + regId = RegistrationId uuid + pair = Pair regId (RegistrationHandler f) + + ~() <- case splitClientMethod method of + IsClientNot -> modifyData $ \ctx -> + let newRegs = DMap.insert method pair (resRegistrationsNot ctx) + in ctx { resRegistrationsNot = newRegs } + IsClientReq -> modifyData $ \ctx -> + let newRegs = DMap.insert method pair (resRegistrationsReq ctx) + in ctx { resRegistrationsReq = newRegs } + IsClientEither -> error "Cannot register capability for custom methods" + + -- TODO: handle the scenario where this returns an error + _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () + + pure (Just (RegistrationToken method regId)) + | otherwise = pure Nothing + -- Also I'm thinking we should move this function to somewhere in messages.hs so -- we don't forget to update it when adding new methods... capDyn :: J.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool @@ -749,21 +757,18 @@ registerCapabilityFunc clientCaps method regOpts f _ -> False unregisterCapabilityFunc :: RegistrationToken m -> LspM config () -unregisterCapabilityFunc (RegistrationToken m regId@(RegistrationId uuid)) = do +unregisterCapabilityFunc (RegistrationToken m (RegistrationId uuid)) = do ~() <- case splitClientMethod m of IsClientReq -> do reqRegs <- readData resRegistrationsReq - let f (Compose xs) = Just $ Compose $ filter (\(Pair regId' _) -> regId /= regId') xs - newMap = DMap.update f m reqRegs + let newMap = DMap.delete m reqRegs modifyData (\ctx -> ctx { resRegistrationsReq = newMap }) IsClientNot -> do notRegs <- readData resRegistrationsNot - let f (Compose xs) = Just $ Compose $ filter (\(Pair regId' _) -> regId /= regId') xs - newMap = DMap.update f m notRegs + let newMap = DMap.delete m notRegs modifyData (\ctx -> ctx { resRegistrationsNot = newMap }) - _ -> error "TODO???" - - + IsClientEither -> error "Cannot unregister capability for custom methods" + let unregistration = J.Unregistration uuid (J.SomeClientMethod m) params = J.UnregistrationParams (J.List [unregistration]) void $ mkSendReqFunc SClientUnregisterCapability params $ \_id _res -> pure () From 5d9ac59f2f8ac9e6b364149c9479a8e43ad211a6 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 25 Aug 2020 12:35:11 +0100 Subject: [PATCH 38/63] Make Handler a type synonym --- haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index c6a16ba43..c428054e8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -372,8 +372,7 @@ instance FromJSON (ResponseParams a) => FromJSON (ResponseMessage a) where -- | The type of a handler that handles requests and notifications coming in -- from the server or client -type family Handler m :: Type where - Handler (m :: Method p t) = BaseHandler m (IO ()) +type Handler (m :: Method p t) = BaseHandler m (IO ()) -- | Version of 'Handler' that can be used to construct arbitrary functions -- taking in the required handler arguments From 727b80870c7bcd36903afc259b3493c177439893 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 26 Aug 2020 15:16:59 +0100 Subject: [PATCH 39/63] Remove LspFuncs, expose API through LspM --- example/Reactor.hs | 151 ++--- example/Simple.hs | 23 +- .../src/Language/Haskell/LSP/Types.hs | 2 - .../src/Language/Haskell/LSP/Types/Message.hs | 14 - haskell-lsp.cabal | 4 +- src/Language/Haskell/LSP/Control.hs | 44 +- src/Language/Haskell/LSP/Core.hs | 541 +++++++++--------- src/Language/Haskell/LSP/Utility.hs | 52 -- src/Language/Haskell/LSP/VFS.hs | 8 +- test/InitialConfigurationSpec.hs | 4 +- test/WorkspaceFoldersSpec.hs | 4 +- 11 files changed, 379 insertions(+), 468 deletions(-) delete mode 100644 src/Language/Haskell/LSP/Utility.hs diff --git a/example/Reactor.hs b/example/Reactor.hs index 85fbeab96..0178bb6a2 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -29,21 +29,20 @@ import qualified Control.Exception as E import Control.Lens import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Reader import Control.Monad.STM +import Control.Monad.Trans.Control import qualified Data.Aeson as J import Data.Default import qualified Data.HashMap.Strict as H import qualified Data.Text as T import qualified Language.Haskell.LSP.Control as CTRL -import qualified Language.Haskell.LSP.Core as Core +import Language.Haskell.LSP.Core import Language.Haskell.LSP.Diagnostics import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J -import qualified Language.Haskell.LSP.Utility as U import Language.Haskell.LSP.VFS import System.Exit -import qualified System.Log.Logger as L +import System.Log.Logger -- --------------------------------------------------------------------- @@ -55,41 +54,35 @@ import qualified System.Log.Logger as L main :: IO () main = do - run (return ()) >>= \case + run >>= \case 0 -> exitSuccess c -> exitWith . ExitFailure $ c -- --------------------------------------------------------------------- -run :: IO () -> IO Int -run dispatcherProc = flip E.catches handlers $ do +run :: IO Int +run = flip E.catches handlers $ do rin <- atomically newTChan :: IO (TChan ReactorInput) let - dp lf = do - liftIO $ U.logs "main.run:dp entered" - _rpid <- forkIO $ reactor lf rin - liftIO $ U.logs "main.run:dp tchan" - dispatcherProc - liftIO $ U.logs "main.run:dp after dispatcherProc" - return Nothing - - callbacks = Core.InitializeCallbacks - { Core.onInitialConfiguration = const $ Right () - , Core.onConfigurationChange = const $ Right () - , Core.onStartup = dp + callbacks = InitializeCallbacks + { onInitialConfiguration = const $ Right () + , onConfigurationChange = const $ Right () + , onStartup = do + _reactorThreadId <- (liftBaseDiscard forkIO) (reactor rin) + return Nothing } flip E.finally finalProc $ do - Core.setupLogger Nothing [] L.DEBUG + setupLogger Nothing [] DEBUG CTRL.run callbacks (lspHandlers rin) lspOptions where handlers = [ E.Handler ioExcept , E.Handler someExcept ] - finalProc = L.removeAllHandlers + finalProc = removeAllHandlers ioExcept (e :: E.IOException) = print e >> return 1 someExcept (e :: E.SomeException) = print e >> return 1 @@ -104,9 +97,9 @@ syncOptions = J.TextDocumentSyncOptions , J._save = Just $ J.R $ J.SaveOptions $ Just False } -lspOptions :: Core.Options -lspOptions = def { Core.textDocumentSync = Just syncOptions - , Core.executeCommandCommands = Just ["lsp-hello-command"] +lspOptions :: Options +lspOptions = def { textDocumentSync = Just syncOptions + , executeCommandCommands = Just ["lsp-hello-command"] } -- --------------------------------------------------------------------- @@ -117,48 +110,13 @@ lspOptions = def { Core.textDocumentSync = Just syncOptions data ReactorInput = forall (m :: J.Method 'J.FromClient 'J.Request). - ReactorInputReq (J.SMethod m) (J.RequestMessage m) (Either J.ResponseError (J.ResponseParams m) -> IO ()) + ReactorInputReq (J.SMethod m) (J.RequestMessage m) (Either J.ResponseError (J.ResponseParams m) -> LspM () ()) | forall (m :: J.Method 'J.FromClient 'J.Notification). ReactorInputNot (J.SMethod m) (J.NotificationMessage m) --- --------------------------------------------------------------------- - --- | The monad used in the reactor -type R c a = ReaderT (Core.LspFuncs c) IO a - --- --------------------------------------------------------------------- --- reactor monad functions --- --------------------------------------------------------------------- - --- --------------------------------------------------------------------- - -reactorSendNot :: J.SServerMethod (m :: J.Method 'J.FromServer 'J.Notification) - -> J.MessageParams m - -> R () () -reactorSendNot method params = do - lf <- ask - liftIO $ Core.sendNot lf method params - -reactorSendReq :: J.SServerMethod (m :: J.Method 'J.FromServer 'J.Request) - -> J.MessageParams m - -> (J.LspId m -> Either J.ResponseError (J.ResponseParams m) -> R () ()) - -> R () (J.LspId m) -reactorSendReq method params responseHandler = do - lf <- ask - liftIO $ Core.sendReq lf method params (\lid res -> runReaderT (responseHandler lid res) lf) - --- --------------------------------------------------------------------- - -publishDiagnostics :: Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> R () () -publishDiagnostics maxToPublish uri v diags = do - lf <- ask - liftIO $ Core.publishDiagnosticsFunc lf maxToPublish uri v diags - --- --------------------------------------------------------------------- - -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification -sendDiagnostics :: J.NormalizedUri -> Maybe Int -> R () () +sendDiagnostics :: J.NormalizedUri -> Maybe Int -> LspM () () sendDiagnostics fileUri version = do let diags = [J.Diagnostic @@ -178,10 +136,10 @@ sendDiagnostics fileUri version = do -- | The single point that all events flow through, allowing management of state -- to stitch replies and requests together from the two asynchronous sides: lsp -- server and backend compiler -reactor :: Core.LspFuncs () -> TChan ReactorInput -> IO () -reactor lf inp = do - liftIO $ U.logs "reactor:entered" - flip runReaderT lf $ forever $ do +reactor :: TChan ReactorInput -> LspM () () +reactor inp = do + liftIO $ debugM "reactor" "entered" + forever $ do reactorInput <- liftIO $ atomically $ readTChan inp case reactorInput of ReactorInputReq method msg responder -> @@ -195,21 +153,21 @@ reactor lf inp = do -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as -- input into the reactor -lspHandlers :: TChan ReactorInput -> Core.Handlers +lspHandlers :: TChan ReactorInput -> Handlers () lspHandlers rin method = case handle method of Just _ -> case J.splitClientMethod method of J.IsClientReq -> Just $ \clientMsg responder -> - atomically $ writeTChan rin (ReactorInputReq method clientMsg responder) + liftIO $ atomically $ writeTChan rin (ReactorInputReq method clientMsg responder) J.IsClientNot -> Just $ \clientMsg -> - atomically $ writeTChan rin (ReactorInputNot method clientMsg) + liftIO $ atomically $ writeTChan rin (ReactorInputNot method clientMsg) J.IsClientEither -> error "TODO???" Nothing -> Nothing -- | Where the actual logic resides for handling requests and notifications. -handle :: J.SMethod m -> Maybe (J.BaseHandler m (R () ())) +handle :: J.SMethod m -> Maybe (Handler m ()) handle J.SInitialized = Just $ \_msg -> do - liftIO $ U.logm "Processing the Initialized notification" + liftIO $ debugM "handle" "Processing the Initialized notification" -- We're initialized! Lets send a showMessageRequest now let params = J.ShowMessageRequestParams @@ -217,28 +175,27 @@ handle J.SInitialized = Just $ \_msg -> do "What's your favourite language extension?" (Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"]) - void $ reactorSendReq J.SWindowShowMessageRequest params $ \_lid res -> + void $ sendRequest J.SWindowShowMessageRequest params $ \res -> case res of - Left e -> liftIO $ U.logs $ "Got an error: " ++ show e + Left e -> liftIO $ errorM "handle" $ "Got an error: " ++ show e Right _ -> do - reactorSendNot J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") + sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") -- We can dynamically register a capability once the user accepts it - reactorSendNot J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") + sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") - Core.LspFuncs { Core.registerCapability = registerCapability } <- ask let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) - void $ liftIO $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do - liftIO $ U.logs "Processing a textDocument/codeLens request" + void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do + liftIO $ debugM "handle" "Processing a textDocument/codeLens request" let cmd = J.Command "Say hello" "lsp-hello-command" Nothing rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] - liftIO $ responder (Right rsp) + responder (Right rsp) handle J.STextDocumentDidOpen = Just $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc - liftIO $ U.logs $ "Processing DidOpenTextDocument for: " ++ show fileName + liftIO $ debugM "handle" $ "Processing DidOpenTextDocument for: " ++ show fileName sendDiagnostics (J.toNormalizedUri doc) (Just 0) handle J.STextDocumentDidChange = Just $ \msg -> do @@ -246,46 +203,44 @@ handle J.STextDocumentDidChange = Just $ \msg -> do . J.textDocument . J.uri . to J.toNormalizedUri - liftIO $ U.logs $ "Processing DidChangeTextDocument for: " ++ show doc - lf <- ask - mdoc <- liftIO $ Core.getVirtualFileFunc lf doc + liftIO $ debugM "handle" $ "Processing DidChangeTextDocument for: " ++ show doc + mdoc <- getVirtualFile doc case mdoc of Just (VirtualFile _version str _) -> do - liftIO $ U.logs $ "Found the virtual file: " ++ show str + liftIO $ debugM "handle" $ "Found the virtual file: " ++ show str Nothing -> do - liftIO $ U.logs $ "Didn't find anything in the VFS for: " ++ show doc + liftIO $ debugM "handle" $ "Didn't find anything in the VFS for: " ++ show doc handle J.STextDocumentDidSave = Just $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc - liftIO $ U.logs $ "Processing DidSaveTextDocument for: " ++ show fileName + liftIO $ debugM "handle" $ "Processing DidSaveTextDocument for: " ++ show fileName sendDiagnostics (J.toNormalizedUri doc) Nothing handle J.STextDocumentRename = Just $ \req responder -> do - liftIO $ U.logs "Processing a textDocument/rename request" + liftIO $ debugM "handle" "Processing a textDocument/rename request" let params = req ^. J.params J.Position l c = params ^. J.position newName = params ^. J.newName - lf <- ask - vdoc <- liftIO $ Core.getVersionedTextDocFunc lf (params ^. J.textDocument) + vdoc <- getVersionedTextDoc (params ^. J.textDocument) -- Replace some text at the position with what the user entered let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName tde = J.TextDocumentEdit vdoc (J.List [edit]) -- "documentChanges" field is preferred over "changes" rsp = J.WorkspaceEdit Nothing (Just (J.List [tde])) - liftIO $ responder (Right rsp) + responder (Right rsp) handle J.STextDocumentHover = Just $ \req responder -> do - liftIO $ U.logs "Processing a textDocument/hover request" + liftIO $ debugM "handle" "Processing a textDocument/hover request" let J.HoverParams _doc pos _workDone = req ^. J.params J.Position _l _c' = pos rsp = J.Hover ms (Just range) ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" range = J.Range pos pos - liftIO $ responder (Right rsp) + responder (Right rsp) handle J.STextDocumentCodeAction = Just $ \req responder -> do - liftIO $ U.logs $ "Processing a textDocument/codeAction request" + liftIO $ debugM "handle" $ "Processing a textDocument/codeAction request" let params = req ^. J.params doc = params ^. J.textDocument (J.List diags) = params ^. J.context . J.diagnostics @@ -303,18 +258,18 @@ handle J.STextDocumentCodeAction = Just $ \req responder -> do cmdparams = Just args makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] rsp = J.List $ map J.L $ concatMap makeCommand diags - liftIO $ responder (Right rsp) + responder (Right rsp) handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do - liftIO $ U.logs "Processing a workspace/executeCommand request" + liftIO $ debugM "handle" "Processing a workspace/executeCommand request" let params = req ^. J.params margs = params ^. J.arguments - liftIO $ U.logs $ "The arguments are: " ++ show margs - liftIO $ responder (Right (J.Object mempty)) -- respond to the request + liftIO $ debugM "handle" $ "The arguments are: " ++ show margs + responder (Right (J.Object mempty)) -- respond to the request - reactorSendNot J.SWindowShowMessage - (J.ShowMessageParams J.MtInfo "I was told to execute a command") + sendNotification J.SWindowShowMessage + (J.ShowMessageParams J.MtInfo "I was told to execute a command") handle _ = Nothing diff --git a/example/Simple.hs b/example/Simple.hs index 83109a345..64d87c5ad 100644 --- a/example/Simple.hs +++ b/example/Simple.hs @@ -6,7 +6,26 @@ import Language.Haskell.LSP.Control import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types -handlers :: Handlers +handlers :: Handlers () +handlers SInitialized = Just $ \_not -> do + let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" + (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) + sendRequest SWindowShowMessageRequest params $ \res -> + case res of + Right (Just (MessageActionItem "Turn on")) -> do + let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) + + registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do + let cmd = Command "Say hello" "lsp-hello-command" Nothing + rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right rsp) + pure () + Right _ -> + sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") + Left err -> + sendNotification SWindowShowMessage (ShowMessageParams MtError "Something went wrong!") + pure () + handlers STextDocumentHover = Just $ \req responder -> do let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req Position _l _c' = pos @@ -19,7 +38,7 @@ handlers _ = Nothing initCallbacks = InitializeCallbacks { onInitialConfiguration = const $ Right () , onConfigurationChange = const $ Right () - , onStartup = const $ pure Nothing + , onStartup = pure Nothing } main = run initCallbacks handlers def diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 33e31ab44..4241660c2 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -40,7 +40,6 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.WorkspaceEdit , module Language.Haskell.LSP.Types.WorkspaceFolders , module Language.Haskell.LSP.Types.WorkspaceSymbol - , module Language.Haskell.LSP.Types.Registration ) where @@ -85,4 +84,3 @@ import Language.Haskell.LSP.Types.Window import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types.WorkspaceFolders import Language.Haskell.LSP.Types.WorkspaceSymbol -import Language.Haskell.LSP.Types.Registration diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index c428054e8..51ac7d422 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -366,20 +366,6 @@ instance FromJSON (ResponseParams a) => FromJSON (ResponseMessage a) where (Nothing, Nothing) -> fail "both error and result cannot be Nothing" return $ ResponseMessage _jsonrpc _id $ result --- --------------------------------------------------------------------- --- Handlers --- --------------------------------------------------------------------- - --- | The type of a handler that handles requests and notifications coming in --- from the server or client -type Handler (m :: Method p t) = BaseHandler m (IO ()) - --- | Version of 'Handler' that can be used to construct arbitrary functions --- taking in the required handler arguments -type family BaseHandler (m :: Method p t) (a :: Type) :: Type where - BaseHandler (m :: Method p Request) a = RequestMessage m -> (Either ResponseError (ResponseParams m) -> IO ()) -> a - BaseHandler (m :: Method p Notification) a = NotificationMessage m -> a - -- --------------------------------------------------------------------- -- Helper Type Families -- --------------------------------------------------------------------- diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 3e17e7690..0be83c88b 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -28,7 +28,6 @@ library , Language.Haskell.LSP.Core , Language.Haskell.LSP.Control , Language.Haskell.LSP.Diagnostics - , Language.Haskell.LSP.Utility , Language.Haskell.LSP.VFS -- other-modules: -- other-extensions: @@ -47,6 +46,7 @@ library , haskell-lsp-types == 0.22.* , dependent-map , lens >= 4.15.2 + , monad-control , mtl , network-uri , rope-utf16-splay >= 0.3.1.0 @@ -56,6 +56,7 @@ library , temporary , text , transformers + , transformers-base , time , unordered-containers -- used for generating random uuids for dynamic registration @@ -80,6 +81,7 @@ executable lsp-demo-reactor-server , filepath , hslogger , lens >= 4.15.2 + , monad-control , mtl , network-uri , stm diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs index d040a0fea..627c78e98 100644 --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -19,20 +19,24 @@ import Data.Attoparsec.ByteString.Char8 import qualified Data.ByteString as BS import Data.ByteString.Builder.Extra (defaultChunkSize) import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.List import qualified Language.Haskell.LSP.Core as Core import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Utility import System.IO +import System.Log.Logger -- --------------------------------------------------------------------- -- | Convenience function for 'runWithHandles stdin stdout'. -run :: (Show configs) => Core.InitializeCallbacks configs +run :: (Show config) => Core.InitializeCallbacks config -- ^ function to be called once initialize has -- been received from the client. Further message -- processing will start only after this returns. - -> Core.Handlers + -> Core.Handlers config -> Core.Options -- ^ File to capture the session to. -> IO Int @@ -45,7 +49,7 @@ runWithHandles :: (Show config) => -> Handle -- ^ Handle to write output to. -> Core.InitializeCallbacks config - -> Core.Handlers + -> Core.Handlers config -> Core.Options -> IO Int -- exit code runWithHandles hin hout initializeCallbacks h o = do @@ -73,12 +77,12 @@ runWith :: (Show config) => -> (BSL.ByteString -> IO ()) -- ^ Function to provide output to. -> Core.InitializeCallbacks config - -> Core.Handlers + -> Core.Handlers config -> Core.Options -> IO Int -- exit code runWith clientIn clientOut initializeCallbacks h o = do - logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..." + infoM "haskell-lsp.runWith" "\n\n\n\n\nhaskell-lsp:Starting up server ..." cout <- atomically newTChan :: IO (TChan J.Value) _rhpid <- forkIO $ sendServer cout clientOut @@ -97,7 +101,7 @@ ioLoop => IO BS.ByteString -> Core.InitializeCallbacks config -> VFS - -> Core.Handlers + -> Core.Handlers config -> Core.Options -> (Core.FromServerMessage -> IO ()) -> IO () @@ -108,8 +112,8 @@ ioLoop clientIn initializeCallbacks vfs h o sendMsg = do Just (msg,remainder) -> do case J.eitherDecode $ BSL.fromStrict msg of Left err -> - logm $ B.pack - "\nhaskell-lsp: Got error while decoding initialize:\n" <> str2lbs err <> "\n exiting 1 ...\n" + errorM "haskell-lsp.ioLoop" $ + "Got error while decoding initialize:\n" <> err <> "\n exiting 1 ...\n" Right initialize -> do mInitResp <- Core.initializeRequestHandler initializeCallbacks vfs h o sendMsg initialize case mInitResp of @@ -119,19 +123,19 @@ ioLoop clientIn initializeCallbacks vfs h o sendMsg = do parseOne :: Result BS.ByteString -> IO (Maybe (BS.ByteString,BS.ByteString)) parseOne (Fail _ ctxs err) = do - logm $ B.pack - "\nhaskell-lsp: Failed to parse message header:\n" <> B.intercalate " > " (map str2lbs ctxs) <> ": " <> - str2lbs err <> "\n exiting 1 ...\n" + errorM "haskell-lsp.parseOne" $ + "Failed to parse message header:\n" <> intercalate " > " ctxs <> ": " <> + err <> "\n exiting 1 ...\n" pure Nothing parseOne (Partial c) = do bs <- clientIn if BS.null bs then do - logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n" + errorM "haskell-lsp.parseON" "haskell-lsp:Got EOF, exiting 1 ...\n" pure Nothing else parseOne (c bs) parseOne (Done remainder msg) = do - logm $ B.pack "---> " <> BSL.fromStrict msg + debugM "haskell-lsp.parseOne" $ "---> " <> T.unpack (T.decodeUtf8 msg) pure $ Just (msg,remainder) loop env = go @@ -141,7 +145,7 @@ ioLoop clientIn initializeCallbacks vfs h o sendMsg = do case res of Nothing -> pure () Just (msg,remainder) -> do - Core.runReaderT (Core.handleMessage $ BSL.fromStrict msg) env + Core.runReaderT (Core.runLspT (Core.processMessage $ BSL.fromStrict msg)) env go (parse parser remainder) parser = do @@ -163,12 +167,12 @@ sendServer msgChan clientOut = do let str = J.encode msg let out = BSL.concat - [ str2lbs $ "Content-Length: " ++ show (BSL.length str) - , BSL.fromStrict _TWO_CRLF - , str ] + [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str) + , BSL.fromStrict _TWO_CRLF + , str ] clientOut out - logm $ B.pack "<--2--" <> str + debugM "haskell-lsp.sendServer" $ "<--2--" <> TL.unpack (TL.decodeUtf8 str) -- | -- diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 80a61e287..c928f06e2 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} @@ -14,30 +16,61 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} module Language.Haskell.LSP.Core ( - handleMessage - , LanguageContextData(..) + processMessage , VFSData(..) , InitializeCallbacks(..) - , LspFuncs(..) , Progress(..) , ProgressCancellable(..) , ProgressCancelledException + , Handlers - , RegistrationToken + , Handler + , Options(..) + + , LspT(..) + , LspM + , clientCapabilities + , config + , rootPath + + , sendRequest + , sendNotification + + -- * VFS + , getVirtualFile + , getVirtualFiles + , persistVirtualFile + , getVersionedTextDoc + , reverseFileMap + + -- * Diagnostics + , publishDiagnostics + , flushDiagnosticsBySource + , workspaceFolders + + -- * Progress + , withProgress + , withIndefiniteProgress + + -- * Dynamic registration + , registerCapability + , unregisterCapability + , RegistrationToken + , makeResponseMessage , makeResponseError , setupLogger , reverseSortEdit , initializeRequestHandler - , LspM , runReaderT - , LanguageContextEnv , FromServerMessage ) where @@ -46,7 +79,9 @@ import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad import Control.Applicative +import Control.Monad.Base import Control.Monad.IO.Class +import Control.Monad.Trans.Control import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Control.Monad.Trans.Class @@ -54,13 +89,13 @@ import Control.Lens ( (<&>), (^.), (^?), _Just ) import qualified Data.Aeson as J import qualified Data.Aeson.Types as J import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as B import Data.Default import Data.Functor.Product import Data.IxMap import qualified Data.Dependent.Map as DMap import Data.Dependent.Map (DMap) import qualified Data.HashMap.Strict as HM +import Data.Kind import qualified Data.List as L import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map @@ -68,13 +103,13 @@ import Data.Maybe import Data.Monoid hiding (Product) import qualified Data.Text as T import Data.Text ( Text ) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL import qualified Data.UUID as UUID import Language.Haskell.LSP.Constant --- import Language.Haskell.LSP.Types.MessageFuncs import qualified Language.Haskell.LSP.Types.Capabilities as J import Language.Haskell.LSP.Types as J hiding (Progress) import qualified Language.Haskell.LSP.Types.Lens as J -import Language.Haskell.LSP.Utility import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Diagnostics import System.Directory @@ -95,39 +130,64 @@ import System.Random data LanguageContextEnv config = LanguageContextEnv - { resHandlers :: !Handlers - , resParseConfig :: !(DidChangeConfigurationNotification-> Either T.Text config) + { resHandlers :: !(Handlers config) + , resParseConfig :: !(DidChangeConfigurationNotification -> Either T.Text config) , resSendMessage :: !(FromServerMessage -> IO ()) - , resData :: !(TVar (LanguageContextData config)) + , resState :: !(TVar (LanguageContextState config)) + , resClientCapabilities :: !J.ClientCapabilities + , resRootPath :: !(Maybe FilePath) } + +newtype LspT config m a = LspM { runLspT :: ReaderT (LanguageContextEnv config) m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTransControl) + +instance MonadBase b m => MonadBase b (LspT config m) where + liftBase = liftBaseDefault + +instance MonadBaseControl b m => MonadBaseControl b (LspT config m) where + type StM (LspT config m) a = ComposeSt (LspT config) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +type LspM config = LspT config IO + +-- --------------------------------------------------------------------- +-- Handlers +-- --------------------------------------------------------------------- -- | A mapping from methods to the static 'Handler's that should be used to --- handle them when they come in from the client. -type Handlers = forall t (m :: Method FromClient t). (SMethod m -> Maybe (Handler m)) +-- handle responses when they come in from the client. +type Handlers config = forall t (m :: Method FromClient t). SMethod m -> Maybe (Handler m config) + +-- | The type of a handler that handles requests and notifications coming in +-- from the server or client +type family Handler (m :: Method p t) (config :: Type) = (result :: Type) | result -> config t m where + Handler (m :: Method p Request) config = RequestMessage m -> (Either ResponseError (ResponseParams m) -> LspM config ()) -> LspM config () + Handler (m :: Method p Notification) config = NotificationMessage m -> LspM config () -- | state used by the LSP dispatcher to manage the message loop -data LanguageContextData config = - LanguageContextData +data LanguageContextState config = + LanguageContextState { resVFS :: !VFSData , resDiagnostics :: !DiagnosticStore , resConfig :: !(Maybe config) , resWorkspaceFolders :: ![WorkspaceFolder] , resProgressData :: !ProgressData - , resPendingResponses :: !ResponseMap - , resRegistrationsNot :: !(RegistrationMap Notification) - , resRegistrationsReq :: !(RegistrationMap Request) + , resPendingResponses :: !(ResponseMap config) + , resRegistrationsNot :: !(RegistrationMap config Notification) + , resRegistrationsReq :: !(RegistrationMap config Request) , resLspId :: !Int } -type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) +type ResponseMap config = IxMap LspId (Product SMethod (ServerResponseCallback config)) -type RegistrationMap t = DMap SMethod (Product RegistrationId (RegistrationHandler t)) +type RegistrationMap (config :: Type) (t :: MethodType) = DMap SMethod (Product RegistrationId (RegistrationHandler config t)) data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text deriving Eq -newtype RegistrationHandler (t :: MethodType) (m :: Method FromClient t) = RegistrationHandler (Handler m) +newtype RegistrationHandler config (t :: MethodType) (m :: Method FromClient t) = RegistrationHandler (Handler m config) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -138,21 +198,19 @@ data VFSData = , reverseMap :: !(Map.Map FilePath FilePath) } -type LspM config = ReaderT (LanguageContextEnv config) IO - -modifyData :: (LanguageContextData config -> LanguageContextData config) -> LspM config () -modifyData f = do - tvarDat <- asks resData +modifyState :: (LanguageContextState config -> LanguageContextState config) -> LspM config () +modifyState f = do + tvarDat <- LspM $ asks resState liftIO $ atomically $ modifyTVar' tvarDat f -stateData :: (LanguageContextData config -> (a,LanguageContextData config)) -> LspM config a -stateData f = do - tvarDat <- asks resData +stateState :: (LanguageContextState config -> (a,LanguageContextState config)) -> LspM config a +stateState f = do + tvarDat <- LspM $ asks resState liftIO $ atomically $ stateTVar tvarDat f -readData :: (LanguageContextData config -> a) -> LspM config a -readData f = do - tvarDat <- asks resData +getsState :: (LanguageContextState config -> a) -> LspM config a +getsState f = do + tvarDat <- LspM $ asks resState liftIO $ f <$> readTVarIO tvarDat -- --------------------------------------------------------------------- @@ -191,17 +249,6 @@ instance Default Options where def = Options 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 --- 'textDocument/publishDiagnostics' notification with the total (limited by the --- first parameter) whenever it is updated. -type PublishDiagnosticsFunc = Int -- Max number of diagnostics to send - -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> IO () - --- | A function to remove all diagnostics from a particular source, and send the updates to the client. -type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send - -> Maybe DiagnosticSource -> IO () - -- | A package indicating the perecentage of progress complete and a -- an optional message to go with it during a 'withProgress' -- @@ -221,72 +268,6 @@ instance E.Exception ProgressCancelledException -- @since 0.11.0.0 data ProgressCancellable = Cancellable | NotCancellable -type SendRequestFunc = forall m. - SServerMethod (m :: Method FromServer Request) - -> MessageParams m - -> (LspId m -> Either ResponseError (ResponseParams m) -> IO ()) - -> IO (LspId m) -type SendNotifcationFunc = forall m. - SServerMethod (m :: Method FromServer Notification) - -> MessageParams m - -> IO () - --- | Returned to the server on startup, providing ways to interact with the client. -data LspFuncs c = - LspFuncs - { clientCapabilities :: !J.ClientCapabilities - , config :: !(IO (Maybe c)) - -- ^ Derived from the DidChangeConfigurationNotification message via a - -- server-provided function. - , sendReq :: !SendRequestFunc - -- ^ The function used to send requests to the client and handle their - -- responses. - , sendNot :: !SendNotifcationFunc - -- ^ The function used to send notifications to the client. - , getVirtualFileFunc :: !(NormalizedUri -> IO (Maybe VirtualFile)) - , getVirtualFilesFunc :: !(IO VFS) - -- ^ Function to return the 'VirtualFile' associated with a - -- given 'NormalizedUri', if there is one. - , persistVirtualFileFunc :: !(NormalizedUri -> IO (Maybe FilePath)) - , getVersionedTextDocFunc :: !(TextDocumentIdentifier -> IO VersionedTextDocumentIdentifier) - -- ^ Given a text document identifier, annotate it with the latest version. - , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) - , publishDiagnosticsFunc :: !PublishDiagnosticsFunc - , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc - , rootPath :: !(Maybe FilePath) - , getWorkspaceFolders :: !(IO (Maybe [WorkspaceFolder])) - , withProgress :: !(forall a . Text -> ProgressCancellable - -> ((Progress -> IO ()) -> IO a) -> IO a) - -- ^ Wrapper for reporting progress to the client during a long running - -- task. - -- 'withProgress' @title cancellable f@ starts a new progress reporting - -- session, and finishes it once f is completed. - -- f is provided with an update function that allows it to report on - -- the progress during the session. - -- If @cancellable@ is 'Cancellable', @f@ will be thrown a - -- 'ProgressCancelledException' if the user cancels the action in - -- progress. - -- - -- @since 0.10.0.0 - , withIndefiniteProgress :: !(forall a . Text -> ProgressCancellable - -> IO a -> IO a) - -- ^ Same as 'withProgress', but for processes that do not report the - -- precentage complete. - -- - -- @since 0.10.0.0 - , registerCapability :: !(forall t m. SMethod (m :: Method FromClient t) - -> RegistrationOptions m - -> Handler m - -> IO (Maybe (RegistrationToken m))) - -- ^ Sends a @client/registerCapability@ request and dynamically registers - -- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not - -- support dynamic registration for the specified method, otherwise a - -- 'RegistrationToken' which can be used to unregister it later - , unregisterCapability :: !(forall t (m :: Method FromClient t). RegistrationToken m -> IO ()) - -- ^ Sends a @client/unregisterCapability@ request and removes the handler - -- for that associated registration. - } - -- | Contains all the callbacks to use for initialized the language server. -- it is parameterized over a config type variable representing the type for the -- specific configuration data the language server needs to use. @@ -297,12 +278,12 @@ data InitializeCallbacks config = -- This callback should return either the parsed configuration data or an error indicating -- what went wrong. The parsed configuration object will be stored internally and passed to -- hanlder functions as context. - , onConfigurationChange :: DidChangeConfigurationNotification-> Either T.Text config + , onConfigurationChange :: DidChangeConfigurationNotification -> Either T.Text config -- ^ Invoked whenever the clients sends a message with a changed client configuration. -- This callback should return either the parsed configuration data or an error indicating -- what went wrong. The parsed configuration object will be stored internally and passed to -- hanlder functions as context. - , onStartup :: LspFuncs config -> IO (Maybe ResponseError) + , onStartup :: LspM config (Maybe ResponseError) -- ^ Once the initial configuration has been received, this callback will be invoked to offer -- the language server implementation the chance to create any processes or start new threads -- that may be necesary for the server lifecycle. @@ -310,33 +291,33 @@ data InitializeCallbacks config = -- | A function that a 'Handler' is passed that can be used to respond to a -- request with either an error, or the response params. -newtype ServerResponseCallback (m :: Method FromServer Request) - = ServerResponseCallback (Either ResponseError (ResponseParams m) -> IO ()) +newtype ServerResponseCallback config (m :: Method FromServer Request) + = ServerResponseCallback (Either ResponseError (ResponseParams m) -> LspM config ()) -- | Return value signals if response handler was inserted succesfully -- Might fail if the id was already in the map -addResponseHandler :: LspId m -> (Product SMethod ServerResponseCallback) m -> LspM config Bool +addResponseHandler :: LspId m -> (Product SMethod (ServerResponseCallback config)) m -> LspM config Bool addResponseHandler lid h = do - stateData $ \ctx@LanguageContextData{resPendingResponses} -> + stateState $ \ctx@LanguageContextState{resPendingResponses} -> case insertIxMap lid h resPendingResponses of Just m -> (True, ctx { resPendingResponses = m}) Nothing -> (False, ctx) -mkSendNotFunc :: forall (m :: Method FromServer Notification) config. SServerMethod m -> MessageParams m -> LspM config () -mkSendNotFunc m params = +sendNotification :: forall (m :: Method FromServer Notification) config. SServerMethod m -> MessageParams m -> LspM config () +sendNotification m params = let msg = NotificationMessage "2.0" m params in case splitServerMethod m of IsServerNot -> sendToClient $ fromServerNot msg IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg -mkSendReqFunc :: forall (m :: Method FromServer Request) config. - SServerMethod m - -> MessageParams m - -> (LspId m -> Either ResponseError (ResponseParams m) -> IO ()) - -> LspM config (LspId m) -mkSendReqFunc m params resHandler = do +sendRequest :: forall (m :: Method FromServer Request) config. + SServerMethod m + -> MessageParams m + -> (Either ResponseError (ResponseParams m) -> LspM config ()) + -> LspM config (LspId m) +sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId - success <- addResponseHandler reqId (Pair m (ServerResponseCallback (resHandler reqId))) + success <- addResponseHandler reqId (Pair m (ServerResponseCallback resHandler)) unless success $ error "haskell-lsp: could not send FromServer request as id is reused" let msg = RequestMessage "2.0" reqId m params @@ -361,46 +342,46 @@ handle m msg = _ -> handle' Nothing m msg -handle' :: forall t (m :: Method FromClient t) config. - Maybe (ClientMessage m -> LspM config ()) - -- ^ An action to be run before invoking the handler, used for - -- bookkeeping stuff like the vfs etc. - -> SClientMethod m - -> ClientMessage m - -> LspM config () +handle' :: forall t (m :: Method FromClient t) (config :: Type). + Maybe (ClientMessage m -> LspM config ()) + -- ^ An action to be run before invoking the handler, used for + -- bookkeeping stuff like the vfs etc. + -> SClientMethod m + -> ClientMessage m + -> LspM config () handle' mAction m msg = do maybe (return ()) (\f -> f msg) mAction - dynReqHandlers <- readData resRegistrationsReq - dynNotHandlers <- readData resRegistrationsNot - staticHandlers <- asks resHandlers - sf <- asks resSendMessage + dynReqHandlers <- getsState resRegistrationsReq + dynNotHandlers <- getsState resRegistrationsNot + staticHandlers <- LspM $ asks resHandlers + sf <- LspM$ asks resSendMessage let mStaticHandler = staticHandlers m case splitClientMethod m of IsClientNot -> case pickHandler dynNotHandlers mStaticHandler of - Just h -> liftIO $ h msg + Just h -> h msg Nothing - | SExit <- m -> liftIO $ exitNotificationHandler msg + | SExit <- m -> exitNotificationHandler msg | otherwise -> reportMissingHandler IsClientReq -> case pickHandler dynReqHandlers mStaticHandler of - Just h -> liftIO $ h msg (mkRspCb sf msg) + Just h -> h msg (mkRspCb sf msg) Nothing - | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb sf msg) + | SShutdown <- m -> shutdownRequestHandler msg (mkRspCb sf msg) | otherwise -> reportMissingHandler IsClientEither -> case msg of NotMess noti -> case pickHandler dynNotHandlers mStaticHandler of - Just h -> liftIO $ h noti + Just h -> h noti Nothing -> reportMissingHandler ReqMess req -> case pickHandler dynReqHandlers mStaticHandler of - Just h -> liftIO $ h req (mkRspCb sf req) + Just h -> h req (mkRspCb sf req) Nothing -> reportMissingHandler where -- | Checks to see if there's a dynamic handler, and uses it in favour of the -- static handler, if it exists. - pickHandler :: RegistrationMap t -> Maybe (Handler m) -> Maybe (Handler m) + pickHandler :: RegistrationMap config t -> Maybe (Handler m config) -> Maybe (Handler m config) pickHandler dynHandlerMap mStaticHandler = case (DMap.lookup m dynHandlerMap, mStaticHandler) of (Just (Pair _ (RegistrationHandler h)), _) -> Just h (Nothing, Just h) -> Just h @@ -423,28 +404,28 @@ handle' mAction m msg = do mkRspCb :: (FromServerMessage -> IO ()) -> RequestMessage (m1 :: Method FromClient Request) -> ((Either ResponseError (ResponseParams m1)) - -> IO ()) - mkRspCb sf req (Left err) = sf $ + -> LspM config ()) + mkRspCb sf req (Left err) = liftIO $ sf $ FromServerRsp (req ^. J.method) $ makeResponseError (req ^. J.id) err - mkRspCb sf req (Right rsp) = sf $ + mkRspCb sf req (Right rsp) = liftIO $ sf $ FromServerRsp (req ^. J.method) $ makeResponseMessage (req ^. J.id) rsp handleConfigChange :: DidChangeConfigurationNotification -> LspM config () handleConfigChange req = do - parseConfig <- asks resParseConfig + parseConfig <- LspM $ asks resParseConfig case parseConfig req of Left err -> do let msg = T.pack $ unwords ["haskell-lsp:configuration parse error.", show req, show err] sendErrorLog msg Right newConfig -> - modifyData $ \ctx -> ctx { resConfig = Just newConfig } + modifyState $ \ctx -> ctx { resConfig = Just newConfig } vfsFunc :: (VFS -> b -> (VFS, [String])) -> b -> LspM config () vfsFunc modifyVfs req = do - join $ stateData $ \ctx@LanguageContextData{resVFS = VFSData vfs rm} -> + join $ stateState $ \ctx@LanguageContextState{resVFS = VFSData vfs rm} -> let (vfs', ls) = modifyVfs vfs req - in (liftIO $ mapM_ logs ls,ctx{ resVFS = VFSData vfs' rm}) + in (liftIO $ mapM_ (debugM "haskell-lsp.vfsFunc") ls,ctx{ resVFS = VFSData vfs' rm}) -- | Updates the list of workspace folders updateWorkspaceFolders :: Message WorkspaceDidChangeWorkspaceFolders -> LspM config () @@ -452,22 +433,22 @@ updateWorkspaceFolders (NotificationMessage _ _ params) = do let List toRemove = params ^. J.event . J.removed List toAdd = params ^. J.event . J.added newWfs oldWfs = foldr L.delete oldWfs toRemove <> toAdd - modifyData $ \c -> c {resWorkspaceFolders = newWfs $ resWorkspaceFolders c} + modifyState $ \c -> c {resWorkspaceFolders = newWfs $ resWorkspaceFolders c} -- --------------------------------------------------------------------- -- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. getVirtualFile :: NormalizedUri -> LspM config (Maybe VirtualFile) -getVirtualFile uri = readData $ Map.lookup uri . vfsMap . vfsData . resVFS +getVirtualFile uri = getsState $ Map.lookup uri . vfsMap . vfsData . resVFS getVirtualFiles :: LspM config VFS -getVirtualFiles = readData $ vfsData . resVFS +getVirtualFiles = getsState $ vfsData . resVFS -- | Dump the current text for a given VFS file to a temporary file, -- and return the path to the file. persistVirtualFile :: NormalizedUri -> LspM config (Maybe FilePath) persistVirtualFile uri = do - join $ stateData $ \ctx@LanguageContextData{resVFS = vfs} -> + join $ stateState $ \ctx@LanguageContextState{resVFS = vfs} -> case persistFileVFS (vfsData vfs) uri of Nothing -> (return Nothing, ctx) Just (fn, write) -> @@ -481,6 +462,7 @@ persistVirtualFile uri = do pure (Just fn) in (act, ctx{resVFS = vfs {reverseMap = revMap} }) +-- | Given a text document identifier, annotate it with the latest version. getVersionedTextDoc :: TextDocumentIdentifier -> LspM config VersionedTextDocumentIdentifier getVersionedTextDoc doc = do let uri = doc ^. J.uri @@ -495,14 +477,16 @@ getVersionedTextDoc doc = do -- the temporary file name back to the original one. reverseFileMap :: LspM config (FilePath -> FilePath) reverseFileMap = do - vfs <- readData resVFS + vfs <- getsState resVFS let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs return f -- --------------------------------------------------------------------- -getConfig :: LspM config (Maybe config) -getConfig = readData resConfig +-- | The current configuration from the client as set via the @initialize@ and +-- @workspace/didChangeConfiguration@ requests. +config :: LspM config (Maybe config) +config = getsState resConfig -- --------------------------------------------------------------------- @@ -511,9 +495,9 @@ defaultProgressData = ProgressData 0 Map.empty -- --------------------------------------------------------------------- -handleMessage :: (Show config) => BSL.ByteString -> LspM config () -handleMessage jsonStr = do - tvarDat <- asks resData +processMessage :: (Show config) => BSL.ByteString -> LspM config () +processMessage jsonStr = do + tvarDat <- LspM $ asks resState join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do val <- except $ J.eitherDecode jsonStr ctx <- lift $ readTVar tvarDat @@ -523,17 +507,20 @@ handleMessage jsonStr = do pure $ handle m mess FromClientRsp (Pair (ServerResponseCallback f) (Const newMap)) res -> do modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap }) - pure $ liftIO $ f (res ^. J.result) + pure $ f (res ^. J.result) where - parser :: ResponseMap -> J.Value -> J.Parser (FromClientMessage' (Product ServerResponseCallback (Const ResponseMap))) + parser :: ResponseMap config -> J.Value -> J.Parser (FromClientMessage' (Product (ServerResponseCallback config) (Const (ResponseMap config)))) parser rm = parseClientMessage $ \i -> let (mhandler, newMap) = pickFromIxMap i rm in (\(Pair m handler) -> (m,Pair handler (Const newMap))) <$> mhandler handleErrors = either (sendErrorLog . errMsg) id - errMsg err = T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str jsonStr, show err] - ++ "\n" + errMsg err = TL.toStrict $ TL.unwords + [ "haskell-lsp:incoming message parse error." + , TL.decodeUtf8 jsonStr + , TL.pack err + ] <> "\n" -- --------------------------------------------------------------------- @@ -547,7 +534,7 @@ makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) sendToClient :: FromServerMessage -> LspM config () sendToClient msg = do - f <- asks resSendMessage + f <- LspM $ asks resSendMessage liftIO $ f msg -- --------------------------------------------------------------------- @@ -572,7 +559,7 @@ initializeErrorHandler sendResp e = do freshLspId :: LspM config Int freshLspId = do - stateData $ \c -> + stateState $ \c -> (resLspId c, c{resLspId = resLspId c+1}) -- | Call this to initialize the session @@ -580,7 +567,7 @@ initializeRequestHandler :: forall config. (Show config) => InitializeCallbacks config -> VFS - -> Handlers + -> (Handlers config) -> Options -> (FromServerMessage -> IO ()) -> Message Initialize @@ -597,36 +584,21 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r case rootDir of Nothing -> return () Just dir -> do - logs $ "haskell-lsp:initializeRequestHandler: setting current dir to project root:" ++ dir + debugM "haskell-lsp.initializeRequestHandler" $ "Setting current dir to project root:" ++ dir unless (null dir) $ setCurrentDirectory dir - let - clientSupportsWfs = fromMaybe False $ do - let (J.ClientCapabilities mw _ _ _) = params ^. J.capabilities - (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw - mwf - getWfs tvc - | clientSupportsWfs = atomically $ Just . resWorkspaceFolders <$> readTVar tvc - | otherwise = return Nothing - - clientSupportsProgress = fromMaybe False $ do - let (J.ClientCapabilities _ _ wc _) = params ^. J.capabilities - (J.WindowClientCapabilities mProgress) <- wc - mProgress - - - let wfs = case params ^. J.workspaceFolders of - Just (List xs) -> xs - Nothing -> [] + let initialWfs = case params ^. J.workspaceFolders of + Just (List xs) -> xs + Nothing -> [] initialConfigRes = onInitialConfiguration req initialConfig = either (const Nothing) Just initialConfigRes tvarCtx <- newTVarIO $ - LanguageContextData + LanguageContextState (VFSData vfs mempty) mempty initialConfig - wfs + initialWfs defaultProgressData emptyIxMap mempty @@ -634,42 +606,16 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r 0 -- Launch the given process once the project root directory has been set - let lspFuncs = LspFuncs (params ^. J.capabilities) - (runReaderT getConfig env) - (\a b c -> flip runReaderT env $ mkSendReqFunc a b c) - (\a b -> flip runReaderT env $ mkSendNotFunc a b) - (flip runReaderT env . getVirtualFile) - (flip runReaderT env getVirtualFiles) - (flip runReaderT env . persistVirtualFile) - (flip runReaderT env . getVersionedTextDoc) - (runReaderT reverseFileMap env) - (\a b c d -> flip runReaderT env $ publishDiagnostics a b c d) - (\a b -> flip runReaderT env $ flushDiagnosticsBySource a b) - rootDir - (getWfs tvarCtx) - withProgressFunc - withIndefiniteProgressFunc - (\a b c -> flip runReaderT env $ registerCapabilityFunc (params ^. J.capabilities) a b c) - (flip runReaderT env . unregisterCapabilityFunc) - env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx - - withProgressFunc :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a - withProgressFunc t c f - | clientSupportsProgress = flip runReaderT env $ withProgress' t c f - | otherwise = f (const $ return ()) - withIndefiniteProgressFunc :: Text -> ProgressCancellable -> IO a -> IO a - withIndefiniteProgressFunc t c f - | clientSupportsProgress = flip runReaderT env $ withIndefiniteProgress' t c f - | otherwise = f - - initializationResult <- onStartup lspFuncs + let env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx (params ^. J.capabilities) rootDir + + initializationResult <- flip runReaderT env $ runLspT onStartup case initializationResult of Just errResp -> do sendResp $ makeResponseError (req ^. J.id) errResp Nothing -> do - let capa = serverCapabilities (params ^. J.capabilities) options handlers + let serverCaps = inferServerCapabilities (params ^. J.capabilities) options handlers -- TODO: add API for serverinfo - sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult capa Nothing) + sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult serverCaps Nothing) case initialConfigRes of @@ -677,27 +623,49 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r Left err -> do let msg = T.pack $ unwords ["haskell-lsp:configuration parse error.", show req, show err] - runReaderT (sendErrorLog msg) env + runReaderT (runLspT (sendErrorLog msg)) env return $ Just env -registerCapabilityFunc :: J.ClientCapabilities --- It's not limited to notifications though, its notifications + requests - -> SClientMethod (m :: Method FromClient t) - -> RegistrationOptions m - -> Handler m - -> LspM config (Maybe (RegistrationToken m)) -registerCapabilityFunc clientCaps method regOpts f = do - handlers <- asks resHandlers +clientCapabilities :: LspM config J.ClientCapabilities +clientCapabilities = LspM $ asks resClientCapabilities + +rootPath :: LspM config (Maybe FilePath) +rootPath = LspM $ asks resRootPath + +-- | The current workspace folders, if the client supports workspace folders. +workspaceFolders :: LspM config (Maybe [WorkspaceFolder]) +workspaceFolders = do + clientCaps <- clientCapabilities + let clientSupportsWfs = fromMaybe False $ do + let (J.ClientCapabilities mw _ _ _) = clientCaps + (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw + mwf + if clientSupportsWfs + then Just <$> getsState resWorkspaceFolders + else pure Nothing + +-- | Sends a @client/registerCapability@ request and dynamically registers +-- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not +-- support dynamic registration for the specified method, otherwise a +-- 'RegistrationToken' which can be used to unregister it later. +registerCapability :: forall (config :: Type) t (m :: Method FromClient t). + SClientMethod m + -> RegistrationOptions m + -> Handler m config + -> LspM config (Maybe (RegistrationToken m)) +registerCapability method regOpts f = do + clientCaps <- LspM $ asks resClientCapabilities + handlers <- LspM $ asks resHandlers let alreadyStaticallyRegistered = isJust $ handlers method - go alreadyStaticallyRegistered + go clientCaps alreadyStaticallyRegistered where -- If the server has already registered statically, don't dynamically register -- as per the spec - go True = pure Nothing - go False + go _clientCaps True = pure Nothing + go clientCaps False -- First, check to see if the client supports dynamic registration on this method - | dynamicSupported = do + | dynamicSupported clientCaps = do uuid <- liftIO $ UUID.toText <$> getStdRandom random let registration = J.Registration uuid method regOpts params = J.RegistrationParams (J.List [J.SomeRegistration registration]) @@ -705,16 +673,16 @@ registerCapabilityFunc clientCaps method regOpts f = do pair = Pair regId (RegistrationHandler f) ~() <- case splitClientMethod method of - IsClientNot -> modifyData $ \ctx -> + IsClientNot -> modifyState $ \ctx -> let newRegs = DMap.insert method pair (resRegistrationsNot ctx) in ctx { resRegistrationsNot = newRegs } - IsClientReq -> modifyData $ \ctx -> + IsClientReq -> modifyState $ \ctx -> let newRegs = DMap.insert method pair (resRegistrationsReq ctx) in ctx { resRegistrationsReq = newRegs } IsClientEither -> error "Cannot register capability for custom methods" -- TODO: handle the scenario where this returns an error - _ <- mkSendReqFunc SClientRegisterCapability params $ \_id _res -> pure () + _ <- sendRequest SClientRegisterCapability params $ \_res -> pure () pure (Just (RegistrationToken method regId)) | otherwise = pure Nothing @@ -724,8 +692,9 @@ registerCapabilityFunc clientCaps method regOpts f = do capDyn :: J.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool capDyn (Just x) = fromMaybe False $ x ^. J.dynamicRegistration capDyn Nothing = False + -- | Checks if client capabilities declares that the method supports dynamic registration - dynamicSupported = case method of + dynamicSupported clientCaps = case method of SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just SWorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just SWorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just @@ -756,22 +725,24 @@ registerCapabilityFunc clientCaps method regOpts f = do STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just _ -> False -unregisterCapabilityFunc :: RegistrationToken m -> LspM config () -unregisterCapabilityFunc (RegistrationToken m (RegistrationId uuid)) = do +-- | Sends a @client/unregisterCapability@ request and removes the handler +-- for that associated registration. +unregisterCapability :: RegistrationToken m -> LspM config () +unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do ~() <- case splitClientMethod m of IsClientReq -> do - reqRegs <- readData resRegistrationsReq + reqRegs <- getsState resRegistrationsReq let newMap = DMap.delete m reqRegs - modifyData (\ctx -> ctx { resRegistrationsReq = newMap }) + modifyState (\ctx -> ctx { resRegistrationsReq = newMap }) IsClientNot -> do - notRegs <- readData resRegistrationsNot + notRegs <- getsState resRegistrationsNot let newMap = DMap.delete m notRegs - modifyData (\ctx -> ctx { resRegistrationsNot = newMap }) + modifyState (\ctx -> ctx { resRegistrationsNot = newMap }) IsClientEither -> error "Cannot unregister capability for custom methods" let unregistration = J.Unregistration uuid (J.SomeClientMethod m) params = J.UnregistrationParams (J.List [unregistration]) - void $ mkSendReqFunc SClientUnregisterCapability params $ \_id _res -> pure () + void $ sendRequest SClientUnregisterCapability params $ \_res -> pure () -------------------------------------------------------------------------------- -- PROGRESS @@ -780,25 +751,25 @@ unregisterCapabilityFunc (RegistrationToken m (RegistrationId uuid)) = do storeProgress :: ProgressToken -> Async a -> LspM config () storeProgress n a = do let f = Map.insert n (cancelWith a ProgressCancelledException) . progressCancel - modifyData $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} + modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} deleteProgress :: ProgressToken -> LspM config () deleteProgress n = do let f = Map.delete n . progressCancel - modifyData $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} + modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} -- Get a new id for the progress session and make a new one getNewProgressId :: LspM config ProgressToken getNewProgressId = do - stateData $ \ctx@LanguageContextData{resProgressData} -> + stateState $ \ctx@LanguageContextState{resProgressData} -> let x = progressNextId resProgressData ctx' = ctx { resProgressData = resProgressData { progressNextId = x + 1 }} in (ProgressNumericToken x, ctx') withProgressBase :: Bool -> Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> LspM config a withProgressBase indefinite title cancellable f = do - env <- ask - let sf x = runReaderT (sendToClient x) env + env <- LspM ask + let sf x = runReaderT (runLspT (sendToClient x)) env progId <- getNewProgressId @@ -812,8 +783,8 @@ withProgressBase indefinite title cancellable f = do -- Create progress token -- FIXME : This needs to wait until the request returns before -- continuing!!! - _ <- mkSendReqFunc SWindowWorkDoneProgressCreate - (WorkDoneProgressCreateParams progId) $ \_ res -> do + _ <- sendRequest SWindowWorkDoneProgressCreate + (WorkDoneProgressCreateParams progId) $ \res -> do case res of -- An error ocurred when the client was setting it up -- No need to do anything then, as per the spec @@ -821,7 +792,7 @@ withProgressBase indefinite title cancellable f = do Right () -> pure () -- Send initial notification - mkSendNotFunc SProgress $ + sendNotification SProgress $ fmap Begin $ ProgressParams progId $ WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage @@ -830,7 +801,7 @@ withProgressBase indefinite title cancellable f = do res <- liftIO $ wait aid -- Send done notification - mkSendNotFunc SProgress $ + sendNotification SProgress $ End <$> (ProgressParams progId (WorkDoneProgressEndParams Nothing)) -- Delete the progress cancellation from the map -- If we don't do this then it's easy to leak things as the map contains any IO action. @@ -843,18 +814,44 @@ withProgressBase indefinite title cancellable f = do fmap Report $ ProgressParams progId $ WorkDoneProgressReportParams Nothing msg percentage -withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> LspM config a -withProgress' = withProgressBase False +clientSupportsProgress :: J.ClientCapabilities -> Bool +clientSupportsProgress (J.ClientCapabilities _ _ wc _) = fromMaybe False $ do + (J.WindowClientCapabilities mProgress) <- wc + mProgress + +-- | Wrapper for reporting progress to the client during a long running +-- task. +-- 'withProgress' @title cancellable f@ starts a new progress reporting +-- session, and finishes it once f is completed. +-- f is provided with an update function that allows it to report on +-- the progress during the session. +-- If @cancellable@ is 'Cancellable', @f@ will be thrown a +-- 'ProgressCancelledException' if the user cancels the action in +-- progress. +withProgress :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> LspM config a +withProgress title cancellable f = do + clientCaps <- clientCapabilities + if clientSupportsProgress clientCaps + then withProgressBase False title cancellable f + else liftIO $ f (const $ return ()) + where -withIndefiniteProgress' :: Text -> ProgressCancellable -> IO a -> LspM config a -withIndefiniteProgress' title cancellable f = - withProgressBase True title cancellable (const f) +-- | Same as 'withProgress', but for processes that do not report the +-- precentage complete. +-- +-- @since 0.10.0.0 +withIndefiniteProgress :: Text -> ProgressCancellable -> IO a -> LspM config a +withIndefiniteProgress title cancellable f = do + clientCaps <- clientCapabilities + if clientSupportsProgress clientCaps + then withProgressBase True title cancellable (const f) + else liftIO f -- | Infers the capabilities based on registered handlers, and sets the appropriate options. -- A provider should be set to Nothing if the server does not support it, unless it is a -- static option. -serverCapabilities :: J.ClientCapabilities -> Options -> Handlers -> J.ServerCapabilities -serverCapabilities clientCaps o h = +inferServerCapabilities :: J.ClientCapabilities -> Options -> Handlers config -> J.ServerCapabilities +inferServerCapabilities clientCaps o h = J.ServerCapabilities { J._textDocumentSync = sync , J._hoverProvider = supportedBool J.STextDocumentHover @@ -962,27 +959,28 @@ serverCapabilities clientCaps o h = progressCancelHandler :: J.WorkDoneProgressCancelNotification -> LspM config () progressCancelHandler (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do - mact <- readData $ Map.lookup tid . progressCancel . resProgressData + mact <- getsState $ Map.lookup tid . progressCancel . resProgressData case mact of Nothing -> return () Just cancelAction -> liftIO $ cancelAction -exitNotificationHandler :: Handler J.Exit -exitNotificationHandler = \_ -> do - logm $ B.pack "haskell-lsp:Got exit, exiting" +exitNotificationHandler :: Handler J.Exit c +exitNotificationHandler = \_ -> liftIO $ do + noticeM "haskell-lsp.exitNotificationHandler" "Got exit, exiting" exitSuccess -- | Default Shutdown handler -shutdownRequestHandler :: Handler J.Shutdown +shutdownRequestHandler :: Handler J.Shutdown c shutdownRequestHandler = \_req k -> do k $ Right J.Empty -- --------------------------------------------------------------------- --- | Take the new diagnostics, update the stored diagnostics for the given file --- and version, and publish the total to the client. +-- | Aggregate all diagnostics pertaining to a particular version of a document, +-- by source, and sends a @textDocument/publishDiagnostics@ notification with +-- the total (limited by the first parameter) whenever it is updated. publishDiagnostics :: Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> LspM config () -publishDiagnostics maxDiagnosticCount uri version diags = join $ stateData $ \ctx -> +publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState $ \ctx -> let ds = updateDiagnostics (resDiagnostics ctx) uri version diags ctx' = ctx{resDiagnostics = ds} mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri @@ -994,10 +992,11 @@ publishDiagnostics maxDiagnosticCount uri version diags = join $ stateData $ \ct -- --------------------------------------------------------------------- --- | Take the new diagnostics, update the stored diagnostics for the given file --- and version, and publish the total to the client. -flushDiagnosticsBySource :: Int -> Maybe DiagnosticSource -> LspM config () -flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateData $ \ctx -> +-- | Remove all diagnostics from a particular source, and send the updates to +-- the client. +flushDiagnosticsBySource :: Int -- ^ Max number of diagnostics to send + -> Maybe DiagnosticSource -> LspM config () +flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState $ \ctx -> let ds = flushBySource (resDiagnostics ctx) msource ctx' = ctx {resDiagnostics = ds} -- Send the updated diagnostics to the client diff --git a/src/Language/Haskell/LSP/Utility.hs b/src/Language/Haskell/LSP/Utility.hs deleted file mode 100644 index e0bdefbbb..000000000 --- a/src/Language/Haskell/LSP/Utility.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Language.Haskell.LSP.Utility where - - --- Based on Phoityne.VSCode.Utility - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import Language.Haskell.LSP.Constant -import System.Log.Logger - --- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} --- --------------------------------------------------------------------- - --- | --- UTF8文字列をByteStringへの変換 --- -str2bs :: String -> BS.ByteString -str2bs = TE.encodeUtf8 . T.pack - --- | --- ByteStringをUTF8文字列への変換 --- -bs2str :: BS.ByteString -> String -bs2str = T.unpack. TE.decodeUtf8 - --- | --- UTF8文字列をLazyByteStringへの変換 --- -str2lbs :: String -> LBS.ByteString -str2lbs = TLE.encodeUtf8 . TL.pack - --- | --- LazyByteStringをUTF8文字列への変換 --- -lbs2str :: LBS.ByteString -> String -lbs2str = TL.unpack. TLE.decodeUtf8 - --- --------------------------------------------------------------------- - -logs :: String -> IO () -logs s = debugM _LOG_NAME s - -logm :: B.ByteString -> IO () -logm str = logs (lbs2str str) diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs index c310ad0a6..ab6ddcd90 100644 --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -53,12 +53,12 @@ import Data.Rope.UTF16 ( Rope ) import qualified Data.Rope.UTF16 as Rope import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J -import Language.Haskell.LSP.Utility import System.FilePath import Data.Hashable import System.Directory import System.IO import System.IO.Temp +import System.Log.Logger -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} @@ -138,7 +138,7 @@ changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do Nothing -> case mChanges of Just cs -> applyEdits $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs Nothing -> do - logs "haskell-lsp:changeVfs:no changes" + debugM "haskell-lsp.changeVfs" "No changes" return initVfs where @@ -159,7 +159,7 @@ changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) notif = J.NotificationMessage "" J.STextDocumentDidChange ps let (vfs',ls) = changeFromClientVFS vfs notif - mapM_ logs ls + mapM_ (debugM "haskell-lsp.changeFromServerVFS") ls return vfs' editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text @@ -194,7 +194,7 @@ persistFileVFS vfs uri = hSetNewlineMode h noNewlineTranslation hSetEncoding h utf8 hPutStr h contents - logs $ "haskell-lsp:persistFileVFS: Writing virtual file: " + debugM "haskell-lsp.persistFileVFS" $ "Writing virtual file: " ++ "uri = " ++ show uri ++ ", virtual file = " ++ show tfn withFile tfn WriteMode writeRaw in Just (tfn, action) diff --git a/test/InitialConfigurationSpec.hs b/test/InitialConfigurationSpec.hs index 43b6302e3..b4ec423a9 100644 --- a/test/InitialConfigurationSpec.hs +++ b/test/InitialConfigurationSpec.hs @@ -35,7 +35,7 @@ spec = handlers = def tvarLspId <- newTVarIO 0 - tvarCtx <- newTVarIO $ defaultLanguageContextData handlers + tvarCtx <- newTVarIO $ defaultLanguageContextState handlers def undefined tvarLspId @@ -44,7 +44,7 @@ spec = vfs let putMsg msg = - let jsonStr = encode msg in handleMessage initCb tvarCtx jsonStr + let jsonStr = encode msg in processMessage initCb tvarCtx jsonStr let initParams = InitializeParams diff --git a/test/WorkspaceFoldersSpec.hs b/test/WorkspaceFoldersSpec.hs index f57a79025..51b8c0cd0 100644 --- a/test/WorkspaceFoldersSpec.hs +++ b/test/WorkspaceFoldersSpec.hs @@ -27,7 +27,7 @@ spec = handlers = def tvarLspId <- newTVarIO 0 - tvarCtx <- newTVarIO $ defaultLanguageContextData handlers + tvarCtx <- newTVarIO $ defaultLanguageContextState handlers def undefined tvarLspId @@ -37,7 +37,7 @@ spec = let putMsg msg = let jsonStr = encode msg - in handleMessage initCb tvarCtx jsonStr + in processMessage initCb tvarCtx jsonStr let starterWorkspaces = List [wf0] initParams = InitializeParams From 344ee525bb7c0422eca13d314505969f8938723e Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 26 Aug 2020 15:52:53 +0100 Subject: [PATCH 40/63] Update withProgress/withIndefiniteProgress --- example/Reactor.hs | 6 ++++-- src/Language/Haskell/LSP/Core.hs | 15 ++++++++------- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 0178bb6a2..0d8ac44e2 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -268,8 +268,10 @@ handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do liftIO $ debugM "handle" $ "The arguments are: " ++ show margs responder (Right (J.Object mempty)) -- respond to the request - sendNotification J.SWindowShowMessage - (J.ShowMessageParams J.MtInfo "I was told to execute a command") + void $ withProgress "Executing some long running command" Cancellable $ \update -> + forM [(0 :: Double)..10] $ \i -> do + update (Progress (Just (i * 10)) (Just "Doing stuff")) + liftIO $ threadDelay (1 * 1000000) handle _ = Nothing diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index c928f06e2..f0a00c04a 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -766,7 +766,7 @@ getNewProgressId = do ctx' = ctx { resProgressData = resProgressData { progressNextId = x + 1 }} in (ProgressNumericToken x, ctx') -withProgressBase :: Bool -> Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> LspM config a +withProgressBase :: Bool -> Text -> ProgressCancellable -> ((Progress -> LspM c ()) -> LspM c a) -> LspM c a withProgressBase indefinite title cancellable f = do env <- LspM ask let sf x = runReaderT (runLspT (sendToClient x)) env @@ -796,7 +796,8 @@ withProgressBase indefinite title cancellable f = do fmap Begin $ ProgressParams progId $ WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage - aid <- liftIO $ async $ f (updater progId (sf . fromServerNot)) + aid <- liftBaseWith $ \runInBase -> + async $ runInBase $ f (updater progId (sf . fromServerNot)) storeProgress progId aid res <- liftIO $ wait aid @@ -810,7 +811,7 @@ withProgressBase indefinite title cancellable f = do return res where updater progId sf (Progress percentage msg) = - sf $ NotificationMessage "2.0" SProgress $ + liftIO $ sf $ NotificationMessage "2.0" SProgress $ fmap Report $ ProgressParams progId $ WorkDoneProgressReportParams Nothing msg percentage @@ -828,24 +829,24 @@ clientSupportsProgress (J.ClientCapabilities _ _ wc _) = fromMaybe False $ do -- If @cancellable@ is 'Cancellable', @f@ will be thrown a -- 'ProgressCancelledException' if the user cancels the action in -- progress. -withProgress :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> LspM config a +withProgress :: Text -> ProgressCancellable -> ((Progress -> LspM config ()) -> LspM config a) -> LspM config a withProgress title cancellable f = do clientCaps <- clientCapabilities if clientSupportsProgress clientCaps then withProgressBase False title cancellable f - else liftIO $ f (const $ return ()) + else f (const $ return ()) where -- | Same as 'withProgress', but for processes that do not report the -- precentage complete. -- -- @since 0.10.0.0 -withIndefiniteProgress :: Text -> ProgressCancellable -> IO a -> LspM config a +withIndefiniteProgress :: Text -> ProgressCancellable -> LspM config a -> LspM config a withIndefiniteProgress title cancellable f = do clientCaps <- clientCapabilities if clientSupportsProgress clientCaps then withProgressBase True title cancellable (const f) - else liftIO f + else f -- | Infers the capabilities based on registered handlers, and sets the appropriate options. -- A provider should be set to Nothing if the server does not support it, unless it is a From 8a5d98b2f8022933cfc9d2e5df975f266825f178 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 26 Aug 2020 15:57:29 +0100 Subject: [PATCH 41/63] Add Option for ServerInfo --- src/Language/Haskell/LSP/Core.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index f0a00c04a..50c1daff1 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -243,11 +243,13 @@ data Options = -- | The commands to be executed on the server. -- If you set `executeCommandHandler`, you **must** set this. , executeCommandCommands :: Maybe [Text] + -- | Information about the server that can be advertised to the client. + , serverInfo :: Maybe J.ServerInfo } instance Default Options where def = Options Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing + Nothing Nothing Nothing Nothing -- | A package indicating the perecentage of progress complete and a -- an optional message to go with it during a 'withProgress' @@ -614,8 +616,7 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r sendResp $ makeResponseError (req ^. J.id) errResp Nothing -> do let serverCaps = inferServerCapabilities (params ^. J.capabilities) options handlers - -- TODO: add API for serverinfo - sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult serverCaps Nothing) + sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult serverCaps (serverInfo options)) case initialConfigRes of From 09177fa600ab0d800adfcdbfae7bcec5ab690fac Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 26 Aug 2020 16:07:38 +0100 Subject: [PATCH 42/63] Put parseConfig into LspM That way the old configuration can be fetched and side effects can be run --- src/Language/Haskell/LSP/Core.hs | 38 +++++++++++++++++--------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 50c1daff1..767806d7c 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -127,16 +127,6 @@ import System.Random {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- - -data LanguageContextEnv config = - LanguageContextEnv - { resHandlers :: !(Handlers config) - , resParseConfig :: !(DidChangeConfigurationNotification -> Either T.Text config) - , resSendMessage :: !(FromServerMessage -> IO ()) - , resState :: !(TVar (LanguageContextState config)) - , resClientCapabilities :: !J.ClientCapabilities - , resRootPath :: !(Maybe FilePath) - } newtype LspT config m a = LspM { runLspT :: ReaderT (LanguageContextEnv config) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTransControl) @@ -151,6 +141,16 @@ instance MonadBaseControl b m => MonadBaseControl b (LspT config m) where type LspM config = LspT config IO +data LanguageContextEnv config = + LanguageContextEnv + { resHandlers :: !(Handlers config) + , resParseConfig :: !(J.Value -> LspM config (Either T.Text config)) + , resSendMessage :: !(FromServerMessage -> IO ()) + , resState :: !(TVar (LanguageContextState config)) + , resClientCapabilities :: !J.ClientCapabilities + , resRootPath :: !(Maybe FilePath) + } + -- --------------------------------------------------------------------- -- Handlers -- --------------------------------------------------------------------- @@ -278,13 +278,14 @@ data InitializeCallbacks config = { onInitialConfiguration :: InitializeRequest -> Either T.Text config -- ^ Invoked on the first message from the language client, containg the client configuration -- This callback should return either the parsed configuration data or an error indicating - -- what went wrong. The parsed configuration object will be stored internally and passed to - -- hanlder functions as context. - , onConfigurationChange :: DidChangeConfigurationNotification -> Either T.Text config - -- ^ Invoked whenever the clients sends a message with a changed client configuration. - -- This callback should return either the parsed configuration data or an error indicating - -- what went wrong. The parsed configuration object will be stored internally and passed to - -- hanlder functions as context. + -- what went wrong. The parsed configuration object will be stored internally and can be + -- accessed via 'config'. + , onConfigurationChange :: J.Value -> LspM config (Either T.Text config) + -- ^ @onConfigurationChange newConfig@ is called whenever the + -- clients sends a message with a changed client configuration. This + -- callback should return either the parsed configuration data or an error + -- indicating what went wrong. The parsed configuration object will be + -- stored internally and can be accessed via 'config'. , onStartup :: LspM config (Maybe ResponseError) -- ^ Once the initial configuration has been received, this callback will be invoked to offer -- the language server implementation the chance to create any processes or start new threads @@ -415,7 +416,8 @@ handle' mAction m msg = do handleConfigChange :: DidChangeConfigurationNotification -> LspM config () handleConfigChange req = do parseConfig <- LspM $ asks resParseConfig - case parseConfig req of + res <- parseConfig (req ^. J.params . J.settings) + case res of Left err -> do let msg = T.pack $ unwords ["haskell-lsp:configuration parse error.", show req, show err] From 7c092e41a1422384a490ff4f548dab09a5d3f0d2 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 26 Aug 2020 17:03:21 +0100 Subject: [PATCH 43/63] Add config example for reactor demo, update logger --- cabal.project | 3 ++ example/Reactor.hs | 63 +++++++++++++++------------- example/Simple.hs | 2 +- haskell-lsp.cabal | 3 +- src/Language/Haskell/LSP/Constant.hs | 13 ------ src/Language/Haskell/LSP/Control.hs | 11 +++-- src/Language/Haskell/LSP/Core.hs | 20 ++++----- 7 files changed, 54 insertions(+), 61 deletions(-) delete mode 100644 src/Language/Haskell/LSP/Constant.hs diff --git a/cabal.project b/cabal.project index ad2012d88..d3e5dbb81 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,6 @@ packages: ./ ./haskell-lsp-types/ + +package haskell-lsp + flags: +demo diff --git a/example/Reactor.hs b/example/Reactor.hs index 0d8ac44e2..c1c1c2672 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} @@ -8,7 +8,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE TypeApplications #-} {- | This is an example language server built with haskell-lsp using a 'Reactor' @@ -35,6 +34,7 @@ import qualified Data.Aeson as J import Data.Default import qualified Data.HashMap.Strict as H import qualified Data.Text as T +import GHC.Generics (Generic) import qualified Language.Haskell.LSP.Control as CTRL import Language.Haskell.LSP.Core import Language.Haskell.LSP.Diagnostics @@ -60,6 +60,9 @@ main = do -- --------------------------------------------------------------------- +data Config = Config { fooTheBar :: Bool, wibbleFactor :: Int } + deriving (Generic, J.ToJSON, J.FromJSON) + run :: IO Int run = flip E.catches handlers $ do @@ -67,15 +70,18 @@ run = flip E.catches handlers $ do let callbacks = InitializeCallbacks - { onInitialConfiguration = const $ Right () - , onConfigurationChange = const $ Right () - , onStartup = do - _reactorThreadId <- (liftBaseDiscard forkIO) (reactor rin) - return Nothing + { onInitialConfiguration = const $ pure (Config False 0) + , onConfigurationChange = \v -> case J.fromJSON v of + J.Error e -> pure $ Left (T.pack e) + J.Success cfg -> do + sendNotification J.SWindowShowMessage $ + J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) + pure $ Right cfg + , onStartup = liftBaseDiscard forkIO (reactor rin) >> pure Nothing } flip E.finally finalProc $ do - setupLogger Nothing [] DEBUG + setupLogger Nothing ["reactor"] DEBUG CTRL.run callbacks (lspHandlers rin) lspOptions where @@ -110,13 +116,13 @@ lspOptions = def { textDocumentSync = Just syncOptions data ReactorInput = forall (m :: J.Method 'J.FromClient 'J.Request). - ReactorInputReq (J.SMethod m) (J.RequestMessage m) (Either J.ResponseError (J.ResponseParams m) -> LspM () ()) + ReactorInputReq (J.SMethod m) (J.RequestMessage m) (Either J.ResponseError (J.ResponseParams m) -> LspM Config ()) | forall (m :: J.Method 'J.FromClient 'J.Notification). ReactorInputNot (J.SMethod m) (J.NotificationMessage m) -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification -sendDiagnostics :: J.NormalizedUri -> Maybe Int -> LspM () () +sendDiagnostics :: J.NormalizedUri -> Maybe Int -> LspM Config () sendDiagnostics fileUri version = do let diags = [J.Diagnostic @@ -128,7 +134,6 @@ sendDiagnostics fileUri version = do Nothing -- tags (Just (J.List [])) ] - -- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r) publishDiagnostics 100 fileUri version (partitionBySource diags) -- --------------------------------------------------------------------- @@ -136,9 +141,9 @@ sendDiagnostics fileUri version = do -- | The single point that all events flow through, allowing management of state -- to stitch replies and requests together from the two asynchronous sides: lsp -- server and backend compiler -reactor :: TChan ReactorInput -> LspM () () +reactor :: TChan ReactorInput -> LspM Config () reactor inp = do - liftIO $ debugM "reactor" "entered" + liftIO $ debugM "reactor" "Started the reactor" forever $ do reactorInput <- liftIO $ atomically $ readTChan inp case reactorInput of @@ -153,7 +158,7 @@ reactor inp = do -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as -- input into the reactor -lspHandlers :: TChan ReactorInput -> Handlers () +lspHandlers :: TChan ReactorInput -> Handlers Config lspHandlers rin method = case handle method of Just _ -> case J.splitClientMethod method of @@ -165,9 +170,9 @@ lspHandlers rin method = Nothing -> Nothing -- | Where the actual logic resides for handling requests and notifications. -handle :: J.SMethod m -> Maybe (Handler m ()) +handle :: J.SMethod m -> Maybe (Handler m Config) handle J.SInitialized = Just $ \_msg -> do - liftIO $ debugM "handle" "Processing the Initialized notification" + liftIO $ debugM "reactor.handle" "Processing the Initialized notification" -- We're initialized! Lets send a showMessageRequest now let params = J.ShowMessageRequestParams @@ -177,7 +182,7 @@ handle J.SInitialized = Just $ \_msg -> do void $ sendRequest J.SWindowShowMessageRequest params $ \res -> case res of - Left e -> liftIO $ errorM "handle" $ "Got an error: " ++ show e + Left e -> liftIO $ errorM "reactor.handle" $ "Got an error: " ++ show e Right _ -> do sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") @@ -187,7 +192,7 @@ handle J.SInitialized = Just $ \_msg -> do let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do - liftIO $ debugM "handle" "Processing a textDocument/codeLens request" + liftIO $ debugM "reactor.handle" "Processing a textDocument/codeLens request" let cmd = J.Command "Say hello" "lsp-hello-command" Nothing rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] responder (Right rsp) @@ -195,7 +200,7 @@ handle J.SInitialized = Just $ \_msg -> do handle J.STextDocumentDidOpen = Just $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc - liftIO $ debugM "handle" $ "Processing DidOpenTextDocument for: " ++ show fileName + liftIO $ debugM "reactor.handle" $ "Processing DidOpenTextDocument for: " ++ show fileName sendDiagnostics (J.toNormalizedUri doc) (Just 0) handle J.STextDocumentDidChange = Just $ \msg -> do @@ -203,22 +208,22 @@ handle J.STextDocumentDidChange = Just $ \msg -> do . J.textDocument . J.uri . to J.toNormalizedUri - liftIO $ debugM "handle" $ "Processing DidChangeTextDocument for: " ++ show doc + liftIO $ debugM "reactor.handle" $ "Processing DidChangeTextDocument for: " ++ show doc mdoc <- getVirtualFile doc case mdoc of Just (VirtualFile _version str _) -> do - liftIO $ debugM "handle" $ "Found the virtual file: " ++ show str + liftIO $ debugM "reactor.handle" $ "Found the virtual file: " ++ show str Nothing -> do - liftIO $ debugM "handle" $ "Didn't find anything in the VFS for: " ++ show doc + liftIO $ debugM "reactor.handle" $ "Didn't find anything in the VFS for: " ++ show doc handle J.STextDocumentDidSave = Just $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc - liftIO $ debugM "handle" $ "Processing DidSaveTextDocument for: " ++ show fileName + liftIO $ debugM "reactor.handle" $ "Processing DidSaveTextDocument for: " ++ show fileName sendDiagnostics (J.toNormalizedUri doc) Nothing handle J.STextDocumentRename = Just $ \req responder -> do - liftIO $ debugM "handle" "Processing a textDocument/rename request" + liftIO $ debugM "reactor.handle" "Processing a textDocument/rename request" let params = req ^. J.params J.Position l c = params ^. J.position newName = params ^. J.newName @@ -231,7 +236,7 @@ handle J.STextDocumentRename = Just $ \req responder -> do responder (Right rsp) handle J.STextDocumentHover = Just $ \req responder -> do - liftIO $ debugM "handle" "Processing a textDocument/hover request" + liftIO $ debugM "reactor.handle" "Processing a textDocument/hover request" let J.HoverParams _doc pos _workDone = req ^. J.params J.Position _l _c' = pos rsp = J.Hover ms (Just range) @@ -240,7 +245,7 @@ handle J.STextDocumentHover = Just $ \req responder -> do responder (Right rsp) handle J.STextDocumentCodeAction = Just $ \req responder -> do - liftIO $ debugM "handle" $ "Processing a textDocument/codeAction request" + liftIO $ debugM "reactor.handle" $ "Processing a textDocument/codeAction request" let params = req ^. J.params doc = params ^. J.textDocument (J.List diags) = params ^. J.context . J.diagnostics @@ -261,11 +266,11 @@ handle J.STextDocumentCodeAction = Just $ \req responder -> do responder (Right rsp) handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do - liftIO $ debugM "handle" "Processing a workspace/executeCommand request" + liftIO $ debugM "reactor.handle" "Processing a workspace/executeCommand request" let params = req ^. J.params margs = params ^. J.arguments - liftIO $ debugM "handle" $ "The arguments are: " ++ show margs + liftIO $ debugM "reactor.handle" $ "The arguments are: " ++ show margs responder (Right (J.Object mempty)) -- respond to the request void $ withProgress "Executing some long running command" Cancellable $ \update -> diff --git a/example/Simple.hs b/example/Simple.hs index 64d87c5ad..23b278690 100644 --- a/example/Simple.hs +++ b/example/Simple.hs @@ -37,7 +37,7 @@ handlers _ = Nothing initCallbacks = InitializeCallbacks { onInitialConfiguration = const $ Right () - , onConfigurationChange = const $ Right () + , onConfigurationChange = const $ pure $ Right () , onStartup = pure Nothing } diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 0be83c88b..699b4061b 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -24,8 +24,7 @@ library reexported-modules: Language.Haskell.LSP.Types , Language.Haskell.LSP.Types.Capabilities , Language.Haskell.LSP.Types.Lens - exposed-modules: Language.Haskell.LSP.Constant - , Language.Haskell.LSP.Core + exposed-modules: Language.Haskell.LSP.Core , Language.Haskell.LSP.Control , Language.Haskell.LSP.Diagnostics , Language.Haskell.LSP.VFS diff --git a/src/Language/Haskell/LSP/Constant.hs b/src/Language/Haskell/LSP/Constant.hs deleted file mode 100644 index 0cd9cdf10..000000000 --- a/src/Language/Haskell/LSP/Constant.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Language.Haskell.LSP.Constant where - -_LOG_NAME :: String -_LOG_NAME = "haskell-lsp" - -_LOG_FORMAT :: String --- _LOG_FORMAT = "$time [$tid] $prio $loggername - $msg" -_LOG_FORMAT = "$time [$tid] - $msg" - -_LOG_FORMAT_DATE :: String --- _LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S" -_LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S%Q" - diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs index 627c78e98..b58a30132 100644 --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -32,7 +32,7 @@ import System.Log.Logger -- --------------------------------------------------------------------- -- | Convenience function for 'runWithHandles stdin stdout'. -run :: (Show config) => Core.InitializeCallbacks config +run :: Core.InitializeCallbacks config -- ^ function to be called once initialize has -- been received from the client. Further message -- processing will start only after this returns. @@ -43,7 +43,7 @@ run :: (Show config) => Core.InitializeCallbacks config run = runWithHandles stdin stdout -- | Convenience function for 'runWith' using the specified handles. -runWithHandles :: (Show config) => +runWithHandles :: Handle -- ^ Handle to read client input from. -> Handle @@ -71,7 +71,7 @@ runWithHandles hin hout initializeCallbacks h o = do -- | Starts listening and sending requests and responses -- using the specified I/O. -runWith :: (Show config) => +runWith :: IO BS.ByteString -- ^ Client input. -> (BSL.ByteString -> IO ()) @@ -96,9 +96,8 @@ runWith clientIn clientOut initializeCallbacks h o = do -- --------------------------------------------------------------------- -ioLoop - :: Show config - => IO BS.ByteString +ioLoop :: + IO BS.ByteString -> Core.InitializeCallbacks config -> VFS -> Core.Handlers config diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 767806d7c..9377a07cb 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -106,7 +106,6 @@ import Data.Text ( Text ) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.UUID as UUID -import Language.Haskell.LSP.Constant import qualified Language.Haskell.LSP.Types.Capabilities as J import Language.Haskell.LSP.Types as J hiding (Progress) import qualified Language.Haskell.LSP.Types.Lens as J @@ -333,7 +332,7 @@ sendRequest m params resHandler = do -- | Invokes the registered dynamic or static handlers for the given message and -- method, as well as doing some bookkeeping. -handle :: (Show config) => SClientMethod m -> ClientMessage m -> LspM config () +handle :: SClientMethod m -> ClientMessage m -> LspM config () handle m msg = case m of SWorkspaceDidChangeWorkspaceFolders -> handle' (Just updateWorkspaceFolders) m msg @@ -499,7 +498,7 @@ defaultProgressData = ProgressData 0 Map.empty -- --------------------------------------------------------------------- -processMessage :: (Show config) => BSL.ByteString -> LspM config () +processMessage :: BSL.ByteString -> LspM config () processMessage jsonStr = do tvarDat <- LspM $ asks resState join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do @@ -568,8 +567,7 @@ freshLspId = do -- | Call this to initialize the session initializeRequestHandler - :: forall config. (Show config) - => InitializeCallbacks config + :: InitializeCallbacks config -> VFS -> (Handlers config) -> Options @@ -1031,18 +1029,20 @@ setupLogger mLogFile extraLogNames level = do logH <- LHS.streamHandler logStream level let logHandle = logH {LHS.closeFunc = hClose} - logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT - logHandler = LH.setFormatter logHandle logFormat + logFormatter = L.tfLogFormatter logDateFormat logFormat + logHandler = LH.setFormatter logHandle logFormatter L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle]) - L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler] - L.updateGlobalLogger _LOG_NAME $ L.setLevel level + L.updateGlobalLogger "haskell-lsp" $ L.setHandlers [logHandler] + L.updateGlobalLogger "haskell-lsp" $ L.setLevel level -- Also route the additional log names to the same log forM_ extraLogNames $ \logName -> do L.updateGlobalLogger logName $ L.setHandlers [logHandler] L.updateGlobalLogger logName $ L.setLevel level - + where + logFormat = "$time [$tid] $prio $loggername:\t$msg" + logDateFormat = "%Y-%m-%d %H:%M:%S%Q" -- --------------------------------------------------------------------- From 4c49e279308ef611c1d63088a69801d10bb9c45c Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 26 Aug 2020 20:47:43 +0100 Subject: [PATCH 44/63] Small bits of tidying up --- haskell-lsp-types/src/Data/IxMap.hs | 4 +- .../src/Language/Haskell/LSP/Types/Lens.hs | 2 + haskell-lsp.cabal | 3 +- hie.yaml | 2 + src/Language/Haskell/LSP/Core.hs | 42 +++++++++---------- 5 files changed, 26 insertions(+), 27 deletions(-) diff --git a/haskell-lsp-types/src/Data/IxMap.hs b/haskell-lsp-types/src/Data/IxMap.hs index bcd5cb24b..699dd559b 100644 --- a/haskell-lsp-types/src/Data/IxMap.hs +++ b/haskell-lsp-types/src/Data/IxMap.hs @@ -36,5 +36,5 @@ lookupIxMap i (IxMap m) = pickFromIxMap :: IxOrd k => k m -> IxMap k f -> (Maybe (f m), IxMap k f) pickFromIxMap i (IxMap m) = case M.updateLookupWithKey (\_ _ -> Nothing) (toBase i) m of - (Nothing,m) -> (Nothing,IxMap m) - (Just (Some k),m) -> (Just (unsafeCoerce k),IxMap m) + (Nothing,m') -> (Nothing,IxMap m') + (Just (Some k),m') -> (Just (unsafeCoerce k),IxMap m') diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs index 93ae7ccf5..673024f5c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Lens.hs @@ -5,6 +5,8 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} module Language.Haskell.LSP.Types.Lens where diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 699b4061b..663b015f7 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -60,7 +60,7 @@ library , unordered-containers -- used for generating random uuids for dynamic registration , random - , uuid + , uuid >= 1.3 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -fprint-explicit-kinds @@ -88,7 +88,6 @@ executable lsp-demo-reactor-server , time , transformers , unordered-containers - , vector -- the package library. Comment this out if you want repl changes to propagate , haskell-lsp if !flag(demo) diff --git a/hie.yaml b/hie.yaml index bb01718f3..bfb5e9466 100644 --- a/hie.yaml +++ b/hie.yaml @@ -11,6 +11,8 @@ cradle: component: "haskell-lsp-types" - path: "./src" component: "haskell-lsp" + - path: "./test" + component: "haskell-lsp-test" - path: "./example/Reactor.hs" component: "lsp-demo-reactor-server" - path: "./example/Simple.hs" diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 9377a07cb..6440f5843 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -26,20 +26,21 @@ module Language.Haskell.LSP.Core ( processMessage , VFSData(..) , InitializeCallbacks(..) - , Progress(..) - , ProgressCancellable(..) - , ProgressCancelledException + -- * Handlers , Handlers , Handler , Options(..) + -- * LspT and LspM , LspT(..) , LspM + , clientCapabilities , config , rootPath + , workspaceFolders , sendRequest , sendNotification @@ -54,19 +55,19 @@ module Language.Haskell.LSP.Core ( -- * Diagnostics , publishDiagnostics , flushDiagnosticsBySource - , workspaceFolders -- * Progress , withProgress , withIndefiniteProgress + , Progress(..) + , ProgressCancellable(..) + , ProgressCancelledException -- * Dynamic registration , registerCapability , unregisterCapability , RegistrationToken - , makeResponseMessage - , makeResponseError , setupLogger , reverseSortEdit , initializeRequestHandler @@ -357,7 +358,6 @@ handle' mAction m msg = do dynReqHandlers <- getsState resRegistrationsReq dynNotHandlers <- getsState resRegistrationsNot staticHandlers <- LspM $ asks resHandlers - sf <- LspM$ asks resSendMessage let mStaticHandler = staticHandlers m case splitClientMethod m of @@ -368,9 +368,9 @@ handle' mAction m msg = do | otherwise -> reportMissingHandler IsClientReq -> case pickHandler dynReqHandlers mStaticHandler of - Just h -> h msg (mkRspCb sf msg) + Just h -> h msg (mkRspCb msg) Nothing - | SShutdown <- m -> shutdownRequestHandler msg (mkRspCb sf msg) + | SShutdown <- m -> shutdownRequestHandler msg (mkRspCb msg) | otherwise -> reportMissingHandler IsClientEither -> case msg of @@ -378,7 +378,7 @@ handle' mAction m msg = do Just h -> h noti Nothing -> reportMissingHandler ReqMess req -> case pickHandler dynReqHandlers mStaticHandler of - Just h -> h req (mkRspCb sf req) + Just h -> h req (mkRspCb req) Nothing -> reportMissingHandler where -- | Checks to see if there's a dynamic handler, and uses it in favour of the @@ -403,14 +403,13 @@ handle' mAction m msg = do isOptionalNotification _ = False -- | Makes the callback function passed to a 'Handler' - mkRspCb :: (FromServerMessage -> IO ()) - -> RequestMessage (m1 :: Method FromClient Request) + mkRspCb :: RequestMessage (m1 :: Method FromClient Request) -> ((Either ResponseError (ResponseParams m1)) -> LspM config ()) - mkRspCb sf req (Left err) = liftIO $ sf $ - FromServerRsp (req ^. J.method) $ makeResponseError (req ^. J.id) err - mkRspCb sf req (Right rsp) = liftIO $ sf $ - FromServerRsp (req ^. J.method) $ makeResponseMessage (req ^. J.id) rsp + mkRspCb req (Left err) = sendToClient $ + FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Left err) + mkRspCb req (Right rsp) = sendToClient $ + FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Right rsp) handleConfigChange :: DidChangeConfigurationNotification -> LspM config () handleConfigChange req = do @@ -525,13 +524,6 @@ processMessage jsonStr = do , TL.pack err ] <> "\n" --- --------------------------------------------------------------------- - -makeResponseMessage :: LspId m -> ResponseParams m -> ResponseMessage m -makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) - -makeResponseError :: LspId m -> ResponseError -> ResponseMessage m -makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) -- --------------------------------------------------------------------- @@ -627,6 +619,10 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r runReaderT (runLspT (sendErrorLog msg)) env return $ Just env + + where + makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) + makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) clientCapabilities :: LspM config J.ClientCapabilities clientCapabilities = LspM $ asks resClientCapabilities From da41b1a6793dcf97e32a1668906c403b4b192337 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 27 Aug 2020 15:00:27 +0100 Subject: [PATCH 45/63] Rename WorkDoneProgressCancel => WindowWorkDoneProgressCancel Brings it inline with WindoWorkDoneProgressCreate --- .../src/Language/Haskell/LSP/Types/Message.hs | 9 +++++---- .../src/Language/Haskell/LSP/Types/Method.hs | 13 +++++++------ .../src/Language/Haskell/LSP/Types/Synonyms.hs | 2 +- src/Language/Haskell/LSP/Core.hs | 2 +- 4 files changed, 14 insertions(+), 12 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 51ac7d422..231e1da8d 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -83,8 +83,6 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams WorkspaceDidChangeWatchedFiles = DidChangeWatchedFilesParams MessageParams WorkspaceSymbol = WorkspaceSymbolParams MessageParams WorkspaceExecuteCommand = ExecuteCommandParams - -- Progress - MessageParams WorkDoneProgressCancel = WorkDoneProgressCancelParams -- Sync/Document state MessageParams TextDocumentDidOpen = DidOpenTextDocumentParams MessageParams TextDocumentDidChange = DidChangeTextDocumentParams @@ -130,10 +128,13 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams WindowShowMessage = ShowMessageParams MessageParams WindowShowMessageRequest = ShowMessageRequestParams MessageParams WindowLogMessage = LogMessageParams + -- Progress MessageParams WindowWorkDoneProgressCreate = WorkDoneProgressCreateParams + MessageParams WindowWorkDoneProgressCancel = WorkDoneProgressCancelParams MessageParams Progress = ProgressParams SomeProgressParams + -- Telemetry MessageParams TelemetryEvent = Value - -- Capability + -- Client MessageParams ClientRegisterCapability = RegistrationParams MessageParams ClientUnregisterCapability = UnregistrationParams -- Workspace @@ -562,7 +563,7 @@ splitClientMethod SWorkspaceDidChangeConfiguration = IsClientNot splitClientMethod SWorkspaceDidChangeWatchedFiles = IsClientNot splitClientMethod SWorkspaceSymbol = IsClientReq splitClientMethod SWorkspaceExecuteCommand = IsClientReq -splitClientMethod SWorkDoneProgressCancel = IsClientNot +splitClientMethod SWindowWorkDoneProgressCancel = IsClientNot splitClientMethod STextDocumentDidOpen = IsClientNot splitClientMethod STextDocumentDidChange = IsClientNot splitClientMethod STextDocumentWillSave = IsClientNot diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index c49eabdc4..4046749d9 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -36,8 +36,6 @@ data Method (p :: Provenance) (t :: MethodType) where WorkspaceDidChangeWatchedFiles :: Method FromClient Notification WorkspaceSymbol :: Method FromClient Request WorkspaceExecuteCommand :: Method FromClient Request - -- Progress - WorkDoneProgressCancel :: Method FromClient Notification -- Document TextDocumentDidOpen :: Method FromClient Notification TextDocumentDidChange :: Method FromClient Notification @@ -83,10 +81,13 @@ data Method (p :: Provenance) (t :: MethodType) where WindowShowMessage :: Method FromServer Notification WindowShowMessageRequest :: Method FromServer Request WindowLogMessage :: Method FromServer Notification + WindowWorkDoneProgressCancel :: Method FromClient Notification WindowWorkDoneProgressCreate :: Method FromServer Request + -- Progress Progress :: Method FromServer Notification + -- Telemetry TelemetryEvent :: Method FromServer Notification - -- Capability + -- Client ClientRegisterCapability :: Method FromServer Request ClientUnregisterCapability :: Method FromServer Request -- Workspace @@ -113,7 +114,6 @@ data SMethod (m :: Method p t) where SWorkspaceDidChangeWatchedFiles :: SMethod WorkspaceDidChangeWatchedFiles SWorkspaceSymbol :: SMethod WorkspaceSymbol SWorkspaceExecuteCommand :: SMethod WorkspaceExecuteCommand - SWorkDoneProgressCancel :: SMethod WorkDoneProgressCancel STextDocumentDidOpen :: SMethod TextDocumentDidOpen STextDocumentDidChange :: SMethod TextDocumentDidChange STextDocumentWillSave :: SMethod TextDocumentWillSave @@ -150,6 +150,7 @@ data SMethod (m :: Method p t) where SWindowShowMessageRequest :: SMethod WindowShowMessageRequest SWindowLogMessage :: SMethod WindowLogMessage SWindowWorkDoneProgressCreate :: SMethod WindowWorkDoneProgressCreate + SWindowWorkDoneProgressCancel :: SMethod WindowWorkDoneProgressCancel SProgress :: SMethod Progress STelemetryEvent :: SMethod TelemetryEvent SClientRegisterCapability :: SMethod ClientRegisterCapability @@ -267,7 +268,7 @@ instance FromJSON SomeClientMethod where parseJSON (A.String "textDocument/prepareRename") = pure $ SomeClientMethod STextDocumentPrepareRename parseJSON (A.String "textDocument/foldingRange") = pure $ SomeClientMethod STextDocumentFoldingRange parseJSON (A.String "textDocument/selectionRange") = pure $ SomeClientMethod STextDocumentFoldingRange - parseJSON (A.String "window/workDoneProgress/cancel") = pure $ SomeClientMethod SWorkDoneProgressCancel + parseJSON (A.String "window/workDoneProgress/cancel") = pure $ SomeClientMethod SWindowWorkDoneProgressCancel -- Cancelling parseJSON (A.String "$/cancelRequest") = pure $ SomeClientMethod SCancelRequest -- Custom @@ -360,7 +361,7 @@ instance A.ToJSON (SMethod m) where toJSON STextDocumentSelectionRange = A.String "textDocument/selectionRange" toJSON STextDocumentDocumentLink = A.String "textDocument/documentLink" toJSON SDocumentLinkResolve = A.String "documentLink/resolve" - toJSON SWorkDoneProgressCancel = A.String "window/workDoneProgress/cancel" + toJSON SWindowWorkDoneProgressCancel = A.String "window/workDoneProgress/cancel" -- Server -- Window toJSON SWindowShowMessage = A.String "window/showMessage" diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs index 7e127ff0c..ba9d28eb6 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Synonyms.hs @@ -75,7 +75,7 @@ type WorkspaceSymbolsResponse = ResponseMessage WorkspaceSymbol type ExecuteCommandRequest = Message WorkspaceExecuteCommand type ExecuteCommandResponse = ResponseMessage WorkspaceExecuteCommand -type WorkDoneProgressCancelNotification = Message WorkDoneProgressCancel +type WorkDoneProgressCancelNotification = Message WindowWorkDoneProgressCancel -- Document/Sync type DidOpenTextDocumentNotification = Message TextDocumentDidOpen diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 6440f5843..dd414eb59 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -341,7 +341,7 @@ handle m msg = STextDocumentDidOpen -> handle' (Just $ vfsFunc openVFS) m msg STextDocumentDidChange -> handle' (Just $ vfsFunc changeFromClientVFS) m msg STextDocumentDidClose -> handle' (Just $ vfsFunc closeVFS) m msg - SWorkDoneProgressCancel -> handle' (Just progressCancelHandler) m msg + SWindowWorkDoneProgressCancel -> handle' (Just progressCancelHandler) m msg _ -> handle' Nothing m msg From 039f7d6b98f23dfaf9b9050fd5b354c90819fbf4 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 28 Aug 2020 12:35:32 +0100 Subject: [PATCH 46/63] Fix TH on ghc < 8.10 --- haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs index 138c0e1be..07e2eb64c 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Utils.hs @@ -57,7 +57,7 @@ makeRegHelper regOptTypeName = do isConsFromClient _ = return False isMethodFromClient :: Type -> Q Bool isMethodFromClient (PromotedT method) = do - typ <- reifyType method + DataConI _ typ _ <- reify method case typ of AppT (AppT _ (PromotedT n)) _ -> return $ n == fromClientName _ -> return False From 31e9fdeff41ba241a36d843a5d9d9e2514997bda Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 28 Aug 2020 12:35:59 +0100 Subject: [PATCH 47/63] Fix typo in LspT constructor --- src/Language/Haskell/LSP/Core.hs | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index dd414eb59..01f1c4a01 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -36,6 +36,7 @@ module Language.Haskell.LSP.Core ( -- * LspT and LspM , LspT(..) , LspM + , LanguageContextEnv(..) , clientCapabilities , config @@ -81,6 +82,7 @@ import qualified Control.Exception as E import Control.Monad import Control.Applicative import Control.Monad.Base +import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Except @@ -128,8 +130,8 @@ import System.Random {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- -newtype LspT config m a = LspM { runLspT :: ReaderT (LanguageContextEnv config) m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTransControl) +newtype LspT config m a = LspT { runLspT :: ReaderT (LanguageContextEnv config) m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTransControl, MonadFix) instance MonadBase b m => MonadBase b (LspT config m) where liftBase = liftBaseDefault @@ -200,17 +202,17 @@ data VFSData = modifyState :: (LanguageContextState config -> LanguageContextState config) -> LspM config () modifyState f = do - tvarDat <- LspM $ asks resState + tvarDat <- LspT $ asks resState liftIO $ atomically $ modifyTVar' tvarDat f stateState :: (LanguageContextState config -> (a,LanguageContextState config)) -> LspM config a stateState f = do - tvarDat <- LspM $ asks resState + tvarDat <- LspT $ asks resState liftIO $ atomically $ stateTVar tvarDat f getsState :: (LanguageContextState config -> a) -> LspM config a getsState f = do - tvarDat <- LspM $ asks resState + tvarDat <- LspT $ asks resState liftIO $ f <$> readTVarIO tvarDat -- --------------------------------------------------------------------- @@ -357,7 +359,7 @@ handle' mAction m msg = do dynReqHandlers <- getsState resRegistrationsReq dynNotHandlers <- getsState resRegistrationsNot - staticHandlers <- LspM $ asks resHandlers + staticHandlers <- LspT $ asks resHandlers let mStaticHandler = staticHandlers m case splitClientMethod m of @@ -413,7 +415,7 @@ handle' mAction m msg = do handleConfigChange :: DidChangeConfigurationNotification -> LspM config () handleConfigChange req = do - parseConfig <- LspM $ asks resParseConfig + parseConfig <- LspT $ asks resParseConfig res <- parseConfig (req ^. J.params . J.settings) case res of Left err -> do @@ -499,7 +501,7 @@ defaultProgressData = ProgressData 0 Map.empty processMessage :: BSL.ByteString -> LspM config () processMessage jsonStr = do - tvarDat <- LspM $ asks resState + tvarDat <- LspT $ asks resState join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do val <- except $ J.eitherDecode jsonStr ctx <- lift $ readTVar tvarDat @@ -529,7 +531,7 @@ processMessage jsonStr = do sendToClient :: FromServerMessage -> LspM config () sendToClient msg = do - f <- LspM $ asks resSendMessage + f <- LspT $ asks resSendMessage liftIO $ f msg -- --------------------------------------------------------------------- @@ -625,10 +627,10 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) clientCapabilities :: LspM config J.ClientCapabilities -clientCapabilities = LspM $ asks resClientCapabilities +clientCapabilities = LspT $ asks resClientCapabilities rootPath :: LspM config (Maybe FilePath) -rootPath = LspM $ asks resRootPath +rootPath = LspT $ asks resRootPath -- | The current workspace folders, if the client supports workspace folders. workspaceFolders :: LspM config (Maybe [WorkspaceFolder]) @@ -652,8 +654,8 @@ registerCapability :: forall (config :: Type) t (m :: Method FromClient t). -> Handler m config -> LspM config (Maybe (RegistrationToken m)) registerCapability method regOpts f = do - clientCaps <- LspM $ asks resClientCapabilities - handlers <- LspM $ asks resHandlers + clientCaps <- LspT $ asks resClientCapabilities + handlers <- LspT $ asks resHandlers let alreadyStaticallyRegistered = isJust $ handlers method go clientCaps alreadyStaticallyRegistered where @@ -765,7 +767,7 @@ getNewProgressId = do withProgressBase :: Bool -> Text -> ProgressCancellable -> ((Progress -> LspM c ()) -> LspM c a) -> LspM c a withProgressBase indefinite title cancellable f = do - env <- LspM ask + env <- LspT ask let sf x = runReaderT (runLspT (sendToClient x)) env progId <- getNewProgressId From 699faa192a49c5e6859db3181b6a02e08b4534f9 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 28 Aug 2020 15:41:40 +0100 Subject: [PATCH 48/63] Fix CompletionParams context --- haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs index a6e112a50..091588661 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Completion.hs @@ -332,6 +332,6 @@ makeExtendingDatatype "CompletionParams" , ''WorkDoneProgressParams , ''PartialResultParams ] - [ ("_context", [t| CompletionContext |]) ] + [ ("_context", [t| Maybe CompletionContext |]) ] deriveJSON lspOptions ''CompletionParams From bfdc5bbcfecb9a2f72291f9080e2a680e6e721e2 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 1 Sep 2020 17:04:39 +0100 Subject: [PATCH 49/63] Remove onInitialConfiguration See #210 and #211 Also rename Progress to ProgressAmount to avoid clashing with Progress method in haskell-lsp-types Also fix #252, wrapping sendProgress notifications in bracket Also add example func-test for said bug --- cabal.project | 7 ++ example/Reactor.hs | 7 +- example/Simple.hs | 5 +- func-test/FuncTest.hs | 58 +++++++++ func-test/func-test.cabal | 15 +++ .../src/Language/Haskell/LSP/Types.hs | 4 +- .../Haskell/LSP/Types/Capabilities.hs | 7 +- .../src/Language/Haskell/LSP/Types/Common.hs | 5 +- haskell-lsp.cabal | 1 - hie.yaml | 2 + src/Language/Haskell/LSP/Core.hs | 112 +++++++++--------- test/CapabilitiesSpec.hs | 1 + test/DiagnosticsSpec.hs | 20 ++-- test/InitialConfigurationSpec.hs | 65 ---------- test/JsonSpec.hs | 44 +++++-- test/MethodSpec.hs | 6 +- test/ServerCapabilitiesSpec.hs | 13 +- test/WorkspaceFoldersSpec.hs | 99 ++++++++-------- 18 files changed, 251 insertions(+), 220 deletions(-) create mode 100644 func-test/FuncTest.hs create mode 100644 func-test/func-test.cabal delete mode 100644 test/InitialConfigurationSpec.hs diff --git a/cabal.project b/cabal.project index d3e5dbb81..fb4a319d4 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,13 @@ packages: ./ ./haskell-lsp-types/ + ./func-test/ package haskell-lsp flags: +demo + + +source-repository-package + type: git + location: https://github.com/wz1000/lsp-test.git + tag: 826575195f87238c46431ed70bda8f97f079ffc9 diff --git a/example/Reactor.hs b/example/Reactor.hs index c1c1c2672..5988de03c 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -70,14 +70,13 @@ run = flip E.catches handlers $ do let callbacks = InitializeCallbacks - { onInitialConfiguration = const $ pure (Config False 0) - , onConfigurationChange = \v -> case J.fromJSON v of + { onConfigurationChange = \v -> case J.fromJSON v of J.Error e -> pure $ Left (T.pack e) J.Success cfg -> do sendNotification J.SWindowShowMessage $ J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) pure $ Right cfg - , onStartup = liftBaseDiscard forkIO (reactor rin) >> pure Nothing + , doInitialize = const $ liftBaseDiscard forkIO (reactor rin) >> pure Nothing } flip E.finally finalProc $ do @@ -275,7 +274,7 @@ handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do void $ withProgress "Executing some long running command" Cancellable $ \update -> forM [(0 :: Double)..10] $ \i -> do - update (Progress (Just (i * 10)) (Just "Doing stuff")) + update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) liftIO $ threadDelay (1 * 1000000) diff --git a/example/Simple.hs b/example/Simple.hs index 23b278690..0232d3545 100644 --- a/example/Simple.hs +++ b/example/Simple.hs @@ -36,9 +36,8 @@ handlers STextDocumentHover = Just $ \req responder -> do handlers _ = Nothing initCallbacks = InitializeCallbacks - { onInitialConfiguration = const $ Right () - , onConfigurationChange = const $ pure $ Right () - , onStartup = pure Nothing + { onConfigurationChange = const $ pure $ Right () + , doInitialize = const $ pure Nothing } main = run initCallbacks handlers def diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs new file mode 100644 index 000000000..a74588c93 --- /dev/null +++ b/func-test/FuncTest.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs, OverloadedStrings #-} +module Main where + +import Data.Default +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Control +import qualified Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens +import Control.Monad.IO.Class +import System.IO +import Control.Concurrent +import Control.Monad +import System.Process +import Control.Applicative.Combinators +import Control.Monad.Trans.Control +import Control.Lens + +main :: IO () +main = do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + killVar <- newEmptyMVar + + forkIO $ void $ runWithHandles hinRead houtWrite initCallbacks (handlers killVar) def + + Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do + skipManyTill Test.anyMessage $ do + x <- Test.message SProgress + let isBegin (Begin _) = True + isBegin _ = False + guard $ isBegin $ x ^. params . value + liftIO $ putMVar killVar () + skipManyTill Test.anyMessage $ do + x <- Test.message SProgress + let isEnd (End _) = True + isEnd _ = False + guard $ isEnd $ x ^. params . value + liftIO $ putStrLn "Hello, Haskell!" + +initCallbacks :: InitializeCallbacks () +initCallbacks = InitializeCallbacks + { onConfigurationChange = const $ pure $ Right () + , onInitialization = const $ pure Nothing + } + +handlers :: MVar () -> Handlers () +handlers killVar SInitialized = Just $ \noti -> do + tid <- liftBaseDiscard forkIO $ + withProgress "Doing something" NotCancellable $ \updater -> + liftIO $ threadDelay (1 * 1000000) + liftIO $ void $ forkIO $ do + takeMVar killVar + killThread tid + +handlers _ _ = Nothing diff --git a/func-test/func-test.cabal b/func-test/func-test.cabal new file mode 100644 index 000000000..c59d2681a --- /dev/null +++ b/func-test/func-test.cabal @@ -0,0 +1,15 @@ +cabal-version: >=1.10 +name: func-test +version: 0.1.0.0 +build-type: Simple + +executable func-test + main-is: FuncTest.hs + build-depends: base >=4.14 && <4.15 + , lsp-test + , haskell-lsp + , data-default + , process + , lens + , monad-control + default-language: Haskell2010 diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs index 4241660c2..533dceb1f 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types.hs @@ -13,6 +13,7 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.DocumentHighlight , module Language.Haskell.LSP.Types.DocumentLink + , module Language.Haskell.LSP.Types.DocumentSymbol , module Language.Haskell.LSP.Types.FoldingRange , module Language.Haskell.LSP.Types.Formatting , module Language.Haskell.LSP.Types.Hover @@ -29,7 +30,6 @@ module Language.Haskell.LSP.Types , module Language.Haskell.LSP.Types.Rename , module Language.Haskell.LSP.Types.SignatureHelp , module Language.Haskell.LSP.Types.StaticRegistrationOptions - , module Language.Haskell.LSP.Types.DocumentSymbol , module Language.Haskell.LSP.Types.SelectionRange , module Language.Haskell.LSP.Types.Synonyms , module Language.Haskell.LSP.Types.TextDocument @@ -57,6 +57,7 @@ import Language.Haskell.LSP.Types.DocumentColor import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.DocumentHighlight import Language.Haskell.LSP.Types.DocumentLink +import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.FoldingRange import Language.Haskell.LSP.Types.Formatting import Language.Haskell.LSP.Types.Hover @@ -74,7 +75,6 @@ import Language.Haskell.LSP.Types.Rename import Language.Haskell.LSP.Types.SelectionRange import Language.Haskell.LSP.Types.SignatureHelp import Language.Haskell.LSP.Types.StaticRegistrationOptions -import Language.Haskell.LSP.Types.DocumentSymbol import Language.Haskell.LSP.Types.Synonyms import Language.Haskell.LSP.Types.TextDocument import Language.Haskell.LSP.Types.TypeDefinition diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs index 0f4b336a1..14ff46877 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -14,8 +14,7 @@ import Language.Haskell.LSP.Types.ServerCapabilities import Language.Haskell.LSP.Types.WorkspaceEdit import Language.Haskell.LSP.Types --- | The whole shebang. The real deal. --- Capabilities for full conformance to the current (v3.15) LSP specification. +-- | Capabilities for full conformance to the current (v3.15) LSP specification. fullCaps :: ClientCapabilities fullCaps = capsForVersion (LSPVersion maxBound maxBound) @@ -35,7 +34,7 @@ data LSPVersion = LSPVersion Int Int -- ^ Construct a major.minor version -- * 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 Nothing +capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Just window) Nothing where w = WorkspaceClientCapabilities (Just True) @@ -243,3 +242,5 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Noth since x y a | maj >= x && min >= y = Just a | otherwise = Nothing + + window = WindowClientCapabilities (since 3 15 True) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index 87206b7af..e51e00417 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -23,7 +23,10 @@ instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where toJSON (R x) = toJSON x instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where - parseJSON v = L <$> parseJSON v <|> R <$> parseJSON v + -- Important: Try to parse the **rightmost** type first, as in the specification + -- the more complex types tend to appear on the right of the |, i.e. + -- @colorProvider?: boolean | DocumentColorOptions | DocumentColorRegistrationOptions;@ + parseJSON v = R <$> parseJSON v <|> L <$> parseJSON v instance (NFData a, NFData b) => NFData (a |? b) diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 663b015f7..8f22d4cb3 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -125,7 +125,6 @@ test-suite haskell-lsp-test VspSpec WorkspaceEditSpec WorkspaceFoldersSpec - InitialConfigurationSpec build-depends: base , QuickCheck , aeson diff --git a/hie.yaml b/hie.yaml index bfb5e9466..e695c10fd 100644 --- a/hie.yaml +++ b/hie.yaml @@ -13,6 +13,8 @@ cradle: component: "haskell-lsp" - path: "./test" component: "haskell-lsp-test" + - path: "./func-test" + component: "func-test" - path: "./example/Reactor.hs" component: "lsp-demo-reactor-server" - path: "./example/Simple.hs" diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 01f1c4a01..30dcdd6a9 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -32,7 +32,7 @@ module Language.Haskell.LSP.Core ( , Handler , Options(..) - + -- * LspT and LspM , LspT(..) , LspM @@ -45,30 +45,30 @@ module Language.Haskell.LSP.Core ( , sendRequest , sendNotification - + -- * VFS , getVirtualFile , getVirtualFiles , persistVirtualFile , getVersionedTextDoc , reverseFileMap - + -- * Diagnostics , publishDiagnostics , flushDiagnosticsBySource - + -- * Progress , withProgress , withIndefiniteProgress - , Progress(..) + , ProgressAmount(..) , ProgressCancellable(..) , ProgressCancelledException - + -- * Dynamic registration , registerCapability , unregisterCapability , RegistrationToken - + , setupLogger , reverseSortEdit , initializeRequestHandler @@ -110,7 +110,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.UUID as UUID import qualified Language.Haskell.LSP.Types.Capabilities as J -import Language.Haskell.LSP.Types as J hiding (Progress) +import Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Diagnostics @@ -129,7 +129,7 @@ import System.Random {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- - + newtype LspT config m a = LspT { runLspT :: ReaderT (LanguageContextEnv config) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTransControl, MonadFix) @@ -257,7 +257,7 @@ instance Default Options where -- an optional message to go with it during a 'withProgress' -- -- @since 0.10.0.0 -data Progress = Progress (Maybe Double) (Maybe Text) +data ProgressAmount = ProgressAmount (Maybe Double) (Maybe Text) -- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session -- @@ -277,21 +277,18 @@ data ProgressCancellable = Cancellable | NotCancellable -- specific configuration data the language server needs to use. data InitializeCallbacks config = InitializeCallbacks - { onInitialConfiguration :: InitializeRequest -> Either T.Text config - -- ^ Invoked on the first message from the language client, containg the client configuration - -- This callback should return either the parsed configuration data or an error indicating - -- what went wrong. The parsed configuration object will be stored internally and can be - -- accessed via 'config'. - , onConfigurationChange :: J.Value -> LspM config (Either T.Text config) + { onConfigurationChange :: J.Value -> LspM config (Either T.Text config) -- ^ @onConfigurationChange newConfig@ is called whenever the -- clients sends a message with a changed client configuration. This -- callback should return either the parsed configuration data or an error -- indicating what went wrong. The parsed configuration object will be -- stored internally and can be accessed via 'config'. - , onStartup :: LspM config (Maybe ResponseError) - -- ^ Once the initial configuration has been received, this callback will be invoked to offer - -- the language server implementation the chance to create any processes or start new threads + , doInitialize :: InitializeRequest -> LspM config (Maybe ResponseError) + -- ^ Called after receiving the @initialize@ request and before returning the response. + -- This callback will be invoked to offer the language server + -- implementation the chance to create any processes or start new threads -- that may be necesary for the server lifecycle. + -- It can also return an error in the initialization if necessary. } -- | A function that a 'Handler' is passed that can be used to respond to a @@ -356,12 +353,12 @@ handle' :: forall t (m :: Method FromClient t) (config :: Type). -> LspM config () handle' mAction m msg = do maybe (return ()) (\f -> f msg) mAction - + dynReqHandlers <- getsState resRegistrationsReq dynNotHandlers <- getsState resRegistrationsNot staticHandlers <- LspT $ asks resHandlers let mStaticHandler = staticHandlers m - + case splitClientMethod m of IsClientNot -> case pickHandler dynNotHandlers mStaticHandler of Just h -> h msg @@ -390,7 +387,7 @@ handle' mAction m msg = do (Just (Pair _ (RegistrationHandler h)), _) -> Just h (Nothing, Just h) -> Just h (Nothing, Nothing) -> Nothing - + -- '$/' notifications should/could be ignored by server. -- Don't log errors in that case. -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. @@ -410,7 +407,7 @@ handle' mAction m msg = do -> LspM config ()) mkRspCb req (Left err) = sendToClient $ FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Left err) - mkRspCb req (Right rsp) = sendToClient $ + mkRspCb req (Right rsp) = sendToClient $ FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Right rsp) handleConfigChange :: DidChangeConfigurationNotification -> LspM config () @@ -586,14 +583,12 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r let initialWfs = case params ^. J.workspaceFolders of Just (List xs) -> xs Nothing -> [] - initialConfigRes = onInitialConfiguration req - initialConfig = either (const Nothing) Just initialConfigRes tvarCtx <- newTVarIO $ LanguageContextState (VFSData vfs mempty) mempty - initialConfig + Nothing initialWfs defaultProgressData emptyIxMap @@ -604,7 +599,9 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r -- Launch the given process once the project root directory has been set let env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx (params ^. J.capabilities) rootDir - initializationResult <- flip runReaderT env $ runLspT onStartup + -- Call the 'duringInitialization' callback to let the server kick stuff up + initializationResult <- flip runReaderT env $ runLspT $ doInitialize req + case initializationResult of Just errResp -> do sendResp $ makeResponseError (req ^. J.id) errResp @@ -612,17 +609,9 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r let serverCaps = inferServerCapabilities (params ^. J.capabilities) options handlers sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult serverCaps (serverInfo options)) - - case initialConfigRes of - Right _ -> pure () - Left err -> do - let msg = T.pack $ unwords - ["haskell-lsp:configuration parse error.", show req, show err] - runReaderT (runLspT (sendErrorLog msg)) env - return $ Just env - - where + + where makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) @@ -670,7 +659,7 @@ registerCapability method regOpts f = do params = J.RegistrationParams (J.List [J.SomeRegistration registration]) regId = RegistrationId uuid pair = Pair regId (RegistrationHandler f) - + ~() <- case splitClientMethod method of IsClientNot -> modifyState $ \ctx -> let newRegs = DMap.insert method pair (resRegistrationsNot ctx) @@ -679,19 +668,19 @@ registerCapability method regOpts f = do let newRegs = DMap.insert method pair (resRegistrationsReq ctx) in ctx { resRegistrationsReq = newRegs } IsClientEither -> error "Cannot register capability for custom methods" - + -- TODO: handle the scenario where this returns an error _ <- sendRequest SClientRegisterCapability params $ \_res -> pure () pure (Just (RegistrationToken method regId)) | otherwise = pure Nothing - + -- Also I'm thinking we should move this function to somewhere in messages.hs so -- we don't forget to update it when adding new methods... capDyn :: J.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool capDyn (Just x) = fromMaybe False $ x ^. J.dynamicRegistration capDyn Nothing = False - + -- | Checks if client capabilities declares that the method supports dynamic registration dynamicSupported clientCaps = case method of SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just @@ -723,7 +712,7 @@ registerCapability method regOpts f = do STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just _ -> False - + -- | Sends a @client/unregisterCapability@ request and removes the handler -- for that associated registration. unregisterCapability :: RegistrationToken m -> LspM config () @@ -765,10 +754,8 @@ getNewProgressId = do ctx' = ctx { resProgressData = resProgressData { progressNextId = x + 1 }} in (ProgressNumericToken x, ctx') -withProgressBase :: Bool -> Text -> ProgressCancellable -> ((Progress -> LspM c ()) -> LspM c a) -> LspM c a +withProgressBase :: Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> LspM c ()) -> LspM c a) -> LspM c a withProgressBase indefinite title cancellable f = do - env <- LspT ask - let sf x = runReaderT (runLspT (sendToClient x)) env progId <- getNewProgressId @@ -795,23 +782,31 @@ withProgressBase indefinite title cancellable f = do fmap Begin $ ProgressParams progId $ WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage - aid <- liftBaseWith $ \runInBase -> - async $ runInBase $ f (updater progId (sf . fromServerNot)) - storeProgress progId aid - res <- liftIO $ wait aid + -- Send the begin and done notifications via 'bracket_' so that they are always fired + res <- control $ \runInBase -> + E.bracket_ + -- Send begin notification + (runInBase $ sendNotification SProgress $ + fmap Begin $ ProgressParams progId $ + WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage) + + -- Send end notification + (runInBase $ sendNotification SProgress $ + End <$> ProgressParams progId (WorkDoneProgressEndParams Nothing)) $ do + + -- Run f asynchronously + aid <- async $ runInBase $ f (updater progId) + runInBase $ storeProgress progId aid + wait aid - -- Send done notification - sendNotification SProgress $ - End <$> (ProgressParams progId (WorkDoneProgressEndParams Nothing)) -- Delete the progress cancellation from the map -- If we don't do this then it's easy to leak things as the map contains any IO action. deleteProgress progId - return res - where updater progId sf (Progress percentage msg) = - liftIO $ sf $ NotificationMessage "2.0" SProgress $ - fmap Report $ ProgressParams progId $ + where updater progId (ProgressAmount percentage msg) = do + liftIO $ putStrLn "asdf" + sendNotification SProgress $ fmap Report $ ProgressParams progId $ WorkDoneProgressReportParams Nothing msg percentage clientSupportsProgress :: J.ClientCapabilities -> Bool @@ -828,13 +823,12 @@ clientSupportsProgress (J.ClientCapabilities _ _ wc _) = fromMaybe False $ do -- If @cancellable@ is 'Cancellable', @f@ will be thrown a -- 'ProgressCancelledException' if the user cancels the action in -- progress. -withProgress :: Text -> ProgressCancellable -> ((Progress -> LspM config ()) -> LspM config a) -> LspM config a +withProgress :: Text -> ProgressCancellable -> ((ProgressAmount -> LspM config ()) -> LspM config a) -> LspM config a withProgress title cancellable f = do clientCaps <- clientCapabilities if clientSupportsProgress clientCaps then withProgressBase False title cancellable f else f (const $ return ()) - where -- | Same as 'withProgress', but for processes that do not report the -- precentage complete. @@ -885,7 +879,7 @@ inferServerCapabilities clientCaps o h = , J._experimental = Nothing :: Maybe J.Value } where - + -- | For when we just return a simple @true@/@false@ to indicate if we -- support the capability supportedBool = Just . J.L . supported_b diff --git a/test/CapabilitiesSpec.hs b/test/CapabilitiesSpec.hs index 10d130ce2..59bac99a9 100644 --- a/test/CapabilitiesSpec.hs +++ b/test/CapabilitiesSpec.hs @@ -1,5 +1,6 @@ module CapabilitiesSpec where +import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import Test.Hspec diff --git a/test/DiagnosticsSpec.hs b/test/DiagnosticsSpec.hs index 3e5d7bcca..43921934e 100644 --- a/test/DiagnosticsSpec.hs +++ b/test/DiagnosticsSpec.hs @@ -205,8 +205,8 @@ diagnosticsSpec = do ] uri = J.toNormalizedUri $ J.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - (getDiagnosticParamsFor 10 ds uri) `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (J.List $ reverse diags)) + getDiagnosticParamsFor 10 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List $ reverse diags)) -- --------------------------------- @@ -222,15 +222,15 @@ diagnosticsSpec = do ] uri = J.toNormalizedUri $ J.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - (getDiagnosticParamsFor 2 ds uri) `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) + getDiagnosticParamsFor 2 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List [ mkDiagnostic (Just "ghcmod") "d" , mkDiagnostic (Just "hlint") "c" ])) - (getDiagnosticParamsFor 1 ds uri) `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) + getDiagnosticParamsFor 1 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List [ mkDiagnostic (Just "ghcmod") "d" ])) @@ -249,8 +249,8 @@ diagnosticsSpec = do ] uri = J.toNormalizedUri $ J.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - (getDiagnosticParamsFor 100 ds uri) `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) + getDiagnosticParamsFor 100 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List [ mkDiagnostic (Just "ghcmod") "d" , mkDiagnostic (Just "hlint") "c" @@ -259,8 +259,8 @@ diagnosticsSpec = do ])) let ds' = flushBySource ds (Just "hlint") - (getDiagnosticParamsFor 100 ds' uri) `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) + getDiagnosticParamsFor 100 ds' uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List [ mkDiagnostic (Just "ghcmod") "d" , mkDiagnostic2 (Just "ghcmod") "b" diff --git a/test/InitialConfigurationSpec.hs b/test/InitialConfigurationSpec.hs deleted file mode 100644 index b4ec423a9..000000000 --- a/test/InitialConfigurationSpec.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE OverloadedStrings, GADTs #-} - -module InitialConfigurationSpec where - -import Control.Concurrent.MVar -import Control.Concurrent.STM -import Data.Aeson -import Data.Default -import Language.Haskell.LSP.Capture -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Types.Capabilities -import Test.Hspec - -spec :: Spec -spec = - describe "initial configuration" $ it "stores initial configuration data" $ initVFS $ \vfs -> do - - lfVar <- newEmptyMVar - - let initialConfigHandler (RequestMessage _ _ SInitialize InitializeParams{_initializationOptions = Just opts}) = - case (fromJSON opts :: Result String) of - Success s -> Right s - _ -> Left "Could not decode configuration" - initialConfigHandler _ = - error "Got the wrong request for the onInitialConfiguration callback" - - initCb :: InitializeCallbacks String - initCb = InitializeCallbacks - initialConfigHandler - (const $ Left "") - (\lf -> putMVar lfVar lf >> return Nothing) - - handlers = def - - tvarLspId <- newTVarIO 0 - tvarCtx <- newTVarIO $ defaultLanguageContextState handlers - def - undefined - tvarLspId - (const $ return ()) - noCapture - vfs - - let putMsg msg = - let jsonStr = encode msg in processMessage initCb tvarCtx jsonStr - - let - initParams = InitializeParams - Nothing - Nothing - (Just (Uri "/foo")) - (Just (Data.Aeson.String "configuration")) - fullCaps - Nothing - Nothing - - initMsg :: InitializeRequest - initMsg = RequestMessage "2.0" (IdInt 0) SInitialize initParams - - putMsg initMsg - contents <- readTVarIO tvarCtx - resConfig contents `shouldBe` Just "configuration" - diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs index 43bdd7392..ec2addee6 100644 --- a/test/JsonSpec.hs +++ b/test/JsonSpec.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -42,10 +45,10 @@ jsonSpec = do prop "HoverContents" (propertyJsonRoundtrip :: HoverContents -> Property) prop "ResponseError" (propertyJsonRoundtrip :: ResponseError -> Property) prop "WatchedFiles" (propertyJsonRoundtrip :: DidChangeWatchedFilesRegistrationOptions -> Property) - prop "ResponseMessage ()" - (propertyJsonRoundtrip :: ResponseMessage () -> Property) - prop "ResponseMessage JSON value" - (propertyJsonRoundtrip :: ResponseMessage J.Value -> Property) + prop "ResponseMessage Initialize" + (propertyJsonRoundtrip :: ResponseMessage 'TextDocumentHover -> Property) + -- prop "ResponseMessage JSON value" + -- (propertyJsonRoundtrip :: ResponseMessage J.Value -> Property) describe "JSON decoding regressions" $ it "CompletionItem" $ (J.decode "{\"jsonrpc\":\"2.0\",\"result\":[{\"label\":\"raisebox\"}],\"id\":1}" :: Maybe CompletionResponse) @@ -58,17 +61,17 @@ responseMessageSpec = do it "decodes result = null" $ do let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"result\": null}" in J.decode input `shouldBe` Just - (ResponseMessage "2.0" (IdRspInt 123) (Right J.Null)) + ((ResponseMessage "2.0" (Just (IdInt 123)) (Right J.Null)) :: ResponseMessage 'WorkspaceExecuteCommand) describe "invalid JSON" $ do it "throws if neither result nor error is present" $ do - (J.eitherDecode "{\"jsonrpc\":\"2.0\",\"id\":1}" :: Either String (ResponseMessage ())) - `shouldBe` Left ("Error in $: Both error and result cannot be Nothing") + (J.eitherDecode "{\"jsonrpc\":\"2.0\",\"id\":1}" :: Either String (ResponseMessage 'Initialize)) + `shouldBe` Left ("Error in $: both error and result cannot be Nothing") it "throws if both result and error are present" $ do (J.eitherDecode - "{\"jsonrpc\":\"2.0\",\"id\": 1,\"result\":1,\"error\":{\"code\":-32700,\"message\":\"\",\"data\":null}}" - :: Either String (ResponseMessage Int)) + "{\"jsonrpc\":\"2.0\",\"id\": 1,\"result\":{\"capabilities\": {}},\"error\":{\"code\":-32700,\"message\":\"\",\"data\":null}}" + :: Either String (ResponseMessage 'Initialize)) `shouldSatisfy` - (either (\err -> isPrefixOf "Error in $: Both error and result cannot be present" err) (\_ -> False)) + (either (\err -> "Error in $: both error and result cannot be present" `isPrefixOf` err) (\_ -> False)) -- --------------------------------------------------------------------- @@ -94,7 +97,22 @@ instance Arbitrary HoverContents where , HoverContents <$> arbitrary ] -instance Arbitrary a => Arbitrary (ResponseMessage a) where +instance Arbitrary Uri where + arbitrary = Uri <$> arbitrary + +instance Arbitrary Position where + arbitrary = Position <$> arbitrary <*> arbitrary + +instance Arbitrary Location where + arbitrary = Location <$> arbitrary <*> arbitrary + +instance Arbitrary Range where + arbitrary = Range <$> arbitrary <*> arbitrary + +instance Arbitrary Hover where + arbitrary = Hover <$> arbitrary <*> arbitrary + +instance Arbitrary (ResponseParams m) => Arbitrary (ResponseMessage m) where arbitrary = oneof [ ResponseMessage @@ -107,8 +125,8 @@ instance Arbitrary a => Arbitrary (ResponseMessage a) where <*> (Left <$> arbitrary) ] -instance Arbitrary LspIdRsp where - arbitrary = oneof [IdRspInt <$> arbitrary, IdRspString <$> arbitrary, pure IdRspNull] +instance Arbitrary (LspId m) where + arbitrary = oneof [IdInt <$> arbitrary, IdString <$> arbitrary] instance Arbitrary ResponseError where arbitrary = ResponseError <$> arbitrary <*> arbitrary <*> pure Nothing diff --git a/test/MethodSpec.hs b/test/MethodSpec.hs index 284869f50..2d5b5854a 100644 --- a/test/MethodSpec.hs +++ b/test/MethodSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DataKinds #-} module MethodSpec where @@ -79,12 +79,12 @@ diagnosticsSpec = do describe "Client Methods" $ do it "maintains roundtrip consistency" $ do forM_ clientMethods $ \m -> do - (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result J.ClientMethod)) + (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result (J.SomeClientMethod))) `shouldBe` (J.Success $ J.String m) describe "Server Methods" $ do it "maintains roundtrip consistency" $ do forM_ serverMethods $ \m -> do - (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result J.ServerMethod)) + (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result (J.SomeServerMethod))) `shouldBe` (J.Success $ J.String m) -- --------------------------------- diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs index 7297374a5..6d2a8846a 100644 --- a/test/ServerCapabilitiesSpec.hs +++ b/test/ServerCapabilitiesSpec.hs @@ -4,6 +4,7 @@ module ServerCapabilitiesSpec where import Control.Lens.Operators import Data.Aeson import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types.Lens import Test.Hspec @@ -13,20 +14,20 @@ spec = describe "server capabilities" $ do describe "decodes" $ do it "just id" $ let input = "{\"id\": \"abc123\"}" - in decode input `shouldBe` Just (FoldingRangeOptionsDynamicDocument Nothing (Just "abc123")) + in decode input `shouldBe` Just (FoldingRangeRegistrationOptions Nothing Nothing (Just "abc123")) it "id and document selector" $ let input = "{\"id\": \"foo\", \"documentSelector\": " <> documentFiltersJson <> "}" - in decode input `shouldBe` Just (FoldingRangeOptionsDynamicDocument (Just documentFilters) (Just "foo")) + in decode input `shouldBe` Just (FoldingRangeRegistrationOptions (Just documentFilters) Nothing (Just "foo")) it "static boolean" $ let input = "true" - in decode input `shouldBe` Just (FoldingRangeOptionsStatic True) + in decode input `shouldBe` Just True describe "encodes" $ it "just id" $ - encode (FoldingRangeOptionsDynamicDocument Nothing (Just "foo")) `shouldBe` "{\"id\":\"foo\"}" + encode (FoldingRangeRegistrationOptions Nothing 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")) + Just caps = decode input :: Maybe ServerCapabilities + in caps ^. colorProvider `shouldBe` Just (R $ R $ DocumentColorRegistrationOptions (Just documentFilters) (Just "abc123") Nothing) where documentFilters = List [DocumentFilter (Just "haskell") Nothing Nothing] documentFiltersJson = "[{\"language\": \"haskell\"}]" diff --git a/test/WorkspaceFoldersSpec.hs b/test/WorkspaceFoldersSpec.hs index 51b8c0cd0..04d5f5a13 100644 --- a/test/WorkspaceFoldersSpec.hs +++ b/test/WorkspaceFoldersSpec.hs @@ -6,7 +6,6 @@ import Control.Concurrent.MVar import Control.Concurrent.STM import Data.Aeson import Data.Default -import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types import Language.Haskell.LSP.VFS @@ -14,64 +13,64 @@ import Language.Haskell.LSP.Types.Capabilities import Test.Hspec spec :: Spec -spec = - describe "workspace folders" $ it "keeps track of open workspace folders" $ initVFS $ \vfs -> do +spec = pure () + -- TODO: Convert to a functional test + -- describe "workspace folders" $ it "keeps track of open workspace folders" $ initVFS $ \vfs -> do - lfVar <- newEmptyMVar + -- envVar <- newEmptyMVar - let initCb :: InitializeCallbacks () - initCb = InitializeCallbacks - (const $ Left "") - (const $ Left "") - (\lf -> putMVar lfVar lf >> return Nothing) - handlers = def + -- let initCb :: InitializeCallbacks String + -- initCb = InitializeCallbacks + -- initialConfigHandler + -- (const $ pure $ Left "") + -- (LspT ask >>= liftIO . putMVar envVar >> return Nothing) - tvarLspId <- newTVarIO 0 - tvarCtx <- newTVarIO $ defaultLanguageContextState handlers - def - undefined - tvarLspId - (const $ return ()) - noCapture - vfs + -- tvarLspId <- newTVarIO 0 + -- tvarCtx <- newTVarIO $ defaultLanguageContextState handlers + -- def + -- undefined + -- tvarLspId + -- (const $ return ()) + -- noCapture + -- vfs - let putMsg msg = - let jsonStr = encode msg - in processMessage initCb tvarCtx jsonStr + -- let putMsg msg = + -- let jsonStr = encode msg + -- in processMessage initCb tvarCtx 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 + -- 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 + -- putMsg initMsg - firstWorkspaces <- readMVar lfVar >>= getWorkspaceFolders - firstWorkspaces `shouldBe` Just [wf0] + -- 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 [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] + -- 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" + -- 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 + -- makeNotif add rmv = + -- let addedFolders = List add + -- removedFolders = List rmv + -- ev = WorkspaceFoldersChangeEvent addedFolders removedFolders + -- ps = DidChangeWorkspaceFoldersParams ev + -- in NotificationMessage "2.0" WorkspaceDidChangeWorkspaceFolders ps From fbdc7baef1bce9b58819792033ed377249098eca Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 2 Sep 2020 18:44:00 +0100 Subject: [PATCH 50/63] Make WorksapceFolderSpec a func test --- cabal.project | 4 +- func-test/FuncTest.hs | 143 +++++++++++++----- func-test/func-test.cabal | 5 +- .../src/Language/Haskell/LSP/Types/Message.hs | 2 +- haskell-lsp.cabal | 1 - src/Language/Haskell/LSP/Core.hs | 40 ++--- test/WorkspaceFoldersSpec.hs | 76 ---------- 7 files changed, 132 insertions(+), 139 deletions(-) delete mode 100644 test/WorkspaceFoldersSpec.hs diff --git a/cabal.project b/cabal.project index fb4a319d4..72dd1e669 100644 --- a/cabal.project +++ b/cabal.project @@ -10,4 +10,6 @@ package haskell-lsp source-repository-package type: git location: https://github.com/wz1000/lsp-test.git - tag: 826575195f87238c46431ed70bda8f97f079ffc9 + tag: e251176a4b2ff4dead7846fe5d0a4e1dbea69fd4 + +tests: True diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs index a74588c93..9580c1d11 100644 --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -15,44 +15,109 @@ import Control.Monad import System.Process import Control.Applicative.Combinators import Control.Monad.Trans.Control -import Control.Lens +import Control.Lens hiding (List) +import Test.Hspec +import Data.Maybe +import Control.Concurrent.Async +import Control.Exception +import System.Exit main :: IO () -main = do - (hinRead, hinWrite) <- createPipe - (houtRead, houtWrite) <- createPipe - - killVar <- newEmptyMVar - - forkIO $ void $ runWithHandles hinRead houtWrite initCallbacks (handlers killVar) def - - Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do - skipManyTill Test.anyMessage $ do - x <- Test.message SProgress - let isBegin (Begin _) = True - isBegin _ = False - guard $ isBegin $ x ^. params . value - liftIO $ putMVar killVar () - skipManyTill Test.anyMessage $ do - x <- Test.message SProgress - let isEnd (End _) = True - isEnd _ = False - guard $ isEnd $ x ^. params . value - liftIO $ putStrLn "Hello, Haskell!" - -initCallbacks :: InitializeCallbacks () -initCallbacks = InitializeCallbacks - { onConfigurationChange = const $ pure $ Right () - , onInitialization = const $ pure Nothing - } - -handlers :: MVar () -> Handlers () -handlers killVar SInitialized = Just $ \noti -> do - tid <- liftBaseDiscard forkIO $ - withProgress "Doing something" NotCancellable $ \updater -> - liftIO $ threadDelay (1 * 1000000) - liftIO $ void $ forkIO $ do - takeMVar killVar - killThread tid - -handlers _ _ = Nothing +main = hspec $ do + describe "progress reporting" $ + it "sends end notification if thread is killed" $ do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + killVar <- newEmptyMVar + + let initCallbacks = InitializeCallbacks + { onConfigurationChange = const $ pure $ Right () + , doInitialize = const $ pure Nothing + } + + handlers :: MVar () -> Handlers () + handlers killVar SInitialized = Just $ \noti -> do + tid <- liftBaseDiscard forkIO $ + withProgress "Doing something" NotCancellable $ \updater -> + liftIO $ threadDelay (1 * 1000000) + liftIO $ void $ forkIO $ do + takeMVar killVar + killThread tid + handlers _ _ = Nothing + + forkIO $ void $ runWithHandles hinRead houtWrite initCallbacks (handlers killVar) def + + Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do + -- First make sure that we get a $/progress begin notification + skipManyTill Test.anyMessage $ do + x <- Test.message SProgress + let isBegin (Begin _) = True + isBegin _ = False + guard $ isBegin $ x ^. params . value + + -- Then kill the thread + liftIO $ putMVar killVar () + + -- Then make sure we still get a $/progress end notification + skipManyTill Test.anyMessage $ do + x <- Test.message SProgress + let isEnd (End _) = True + isEnd _ = False + guard $ isEnd $ x ^. params . value + + describe "workspace folders" $ + it "keeps track of open workspace folders" $ do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + countVar <- newMVar 0 + + let wf0 = WorkspaceFolder "one" "Starter workspace" + wf1 = WorkspaceFolder "/foo/bar" "My workspace" + wf2 = WorkspaceFolder "/foo/baz" "My other workspace" + + initCallbacks = InitializeCallbacks + { onConfigurationChange = const $ pure $ Right () + , doInitialize = const $ pure Nothing + } + + handlers :: Handlers () + handlers SInitialized = Just $ \noti -> do + wfs <- fromJust <$> getWorkspaceFolders + liftIO $ wfs `shouldContain` [wf0] + handlers SWorkspaceDidChangeWorkspaceFolders = Just $ \noti -> do + i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i)) + wfs <- fromJust <$> getWorkspaceFolders + liftIO $ case i of + 0 -> do + wfs `shouldContain` [wf1] + wfs `shouldContain` [wf0] + 1 -> do + wfs `shouldNotContain` [wf1] + wfs `shouldContain` [wf0] + wfs `shouldContain` [wf2] + _ -> error "Shouldn't be here" + handlers _ = Nothing + + + server <- async $ void $ runWithHandles hinRead houtWrite initCallbacks handlers def + + let config = Test.defaultConfig + { Test.initialWorkspaceFolders = Just [wf0] + } + + changeFolders add rmv = + let addedFolders = List add + removedFolders = List rmv + ev = WorkspaceFoldersChangeEvent addedFolders removedFolders + ps = DidChangeWorkspaceFoldersParams ev + in Test.sendNotification SWorkspaceDidChangeWorkspaceFolders ps + + Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do + changeFolders [wf1] [] + changeFolders [wf2] [wf1] + + Left e <- waitCatch server + fromException e `shouldBe` Just ExitSuccess + \ No newline at end of file diff --git a/func-test/func-test.cabal b/func-test/func-test.cabal index c59d2681a..5cdf55192 100644 --- a/func-test/func-test.cabal +++ b/func-test/func-test.cabal @@ -3,8 +3,9 @@ name: func-test version: 0.1.0.0 build-type: Simple -executable func-test +test-suite func-test main-is: FuncTest.hs + type: exitcode-stdio-1.0 build-depends: base >=4.14 && <4.15 , lsp-test , haskell-lsp @@ -12,4 +13,6 @@ executable func-test , process , lens , monad-control + , hspec + , async default-language: Haskell2010 diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 231e1da8d..cefc2aab2 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -75,7 +75,7 @@ type family MessageParams (m :: Method p t) :: Type where -- General MessageParams Initialize = InitializeParams MessageParams Initialized = Maybe InitializedParams - MessageParams Shutdown = Maybe Value + MessageParams Shutdown = Empty MessageParams Exit = Empty -- Workspace MessageParams WorkspaceDidChangeWorkspaceFolders = DidChangeWorkspaceFoldersParams diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 8f22d4cb3..439c73e5d 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -124,7 +124,6 @@ test-suite haskell-lsp-test URIFilePathSpec VspSpec WorkspaceEditSpec - WorkspaceFoldersSpec build-depends: base , QuickCheck , aeson diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 30dcdd6a9..fb43ec0b8 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -38,10 +38,10 @@ module Language.Haskell.LSP.Core ( , LspM , LanguageContextEnv(..) - , clientCapabilities - , config - , rootPath - , workspaceFolders + , getClientCapabilities + , getConfig + , getRootPath + , getWorkspaceFolders , sendRequest , sendNotification @@ -484,13 +484,6 @@ reverseFileMap = do -- --------------------------------------------------------------------- --- | The current configuration from the client as set via the @initialize@ and --- @workspace/didChangeConfiguration@ requests. -config :: LspM config (Maybe config) -config = getsState resConfig - --- --------------------------------------------------------------------- - defaultProgressData :: ProgressData defaultProgressData = ProgressData 0 Map.empty @@ -615,16 +608,23 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) -clientCapabilities :: LspM config J.ClientCapabilities -clientCapabilities = LspT $ asks resClientCapabilities +-- --------------------------------------------------------------------- + +-- | The current configuration from the client as set via the @initialize@ and +-- @workspace/didChangeConfiguration@ requests. +getConfig :: LspM config (Maybe config) +getConfig = getsState resConfig + +getClientCapabilities :: LspM config J.ClientCapabilities +getClientCapabilities = LspT $ asks resClientCapabilities -rootPath :: LspM config (Maybe FilePath) -rootPath = LspT $ asks resRootPath +getRootPath :: LspM config (Maybe FilePath) +getRootPath = LspT $ asks resRootPath -- | The current workspace folders, if the client supports workspace folders. -workspaceFolders :: LspM config (Maybe [WorkspaceFolder]) -workspaceFolders = do - clientCaps <- clientCapabilities +getWorkspaceFolders :: LspM config (Maybe [WorkspaceFolder]) +getWorkspaceFolders = do + clientCaps <- getClientCapabilities let clientSupportsWfs = fromMaybe False $ do let (J.ClientCapabilities mw _ _ _) = clientCaps (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw @@ -825,7 +825,7 @@ clientSupportsProgress (J.ClientCapabilities _ _ wc _) = fromMaybe False $ do -- progress. withProgress :: Text -> ProgressCancellable -> ((ProgressAmount -> LspM config ()) -> LspM config a) -> LspM config a withProgress title cancellable f = do - clientCaps <- clientCapabilities + clientCaps <- getClientCapabilities if clientSupportsProgress clientCaps then withProgressBase False title cancellable f else f (const $ return ()) @@ -836,7 +836,7 @@ withProgress title cancellable f = do -- @since 0.10.0.0 withIndefiniteProgress :: Text -> ProgressCancellable -> LspM config a -> LspM config a withIndefiniteProgress title cancellable f = do - clientCaps <- clientCapabilities + clientCaps <- getClientCapabilities if clientSupportsProgress clientCaps then withProgressBase True title cancellable (const f) else f diff --git a/test/WorkspaceFoldersSpec.hs b/test/WorkspaceFoldersSpec.hs deleted file mode 100644 index 04d5f5a13..000000000 --- a/test/WorkspaceFoldersSpec.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module WorkspaceFoldersSpec where - -import Control.Concurrent.MVar -import Control.Concurrent.STM -import Data.Aeson -import Data.Default -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Types.Capabilities -import Test.Hspec - -spec :: Spec -spec = pure () - -- TODO: Convert to a functional test - -- describe "workspace folders" $ it "keeps track of open workspace folders" $ initVFS $ \vfs -> do - - -- envVar <- newEmptyMVar - - -- let initCb :: InitializeCallbacks String - -- initCb = InitializeCallbacks - -- initialConfigHandler - -- (const $ pure $ Left "") - -- (LspT ask >>= liftIO . putMVar envVar >> return Nothing) - - -- tvarLspId <- newTVarIO 0 - -- tvarCtx <- newTVarIO $ defaultLanguageContextState handlers - -- def - -- undefined - -- tvarLspId - -- (const $ return ()) - -- noCapture - -- vfs - - -- let putMsg msg = - -- let jsonStr = encode msg - -- in processMessage initCb tvarCtx 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 From d70912d39465b5f288b52ad417ad44dc9902a6e8 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 28 Sep 2020 19:20:56 +0530 Subject: [PATCH 51/63] fix build --- func-test/func-test.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/func-test/func-test.cabal b/func-test/func-test.cabal index 5cdf55192..654cafb6f 100644 --- a/func-test/func-test.cabal +++ b/func-test/func-test.cabal @@ -6,7 +6,7 @@ build-type: Simple test-suite func-test main-is: FuncTest.hs type: exitcode-stdio-1.0 - build-depends: base >=4.14 && <4.15 + build-depends: base <4.15 , lsp-test , haskell-lsp , data-default From 8e6fbb7ee9caed87814662588954a1716d7c3856 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 28 Sep 2020 15:35:08 +0100 Subject: [PATCH 52/63] Update stack files --- stack-8.4.2.yaml | 1 + stack-8.4.3.yaml | 1 + stack-8.4.4.yaml | 4 ++++ stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 5 +++++ stack-8.8.1.yaml | 7 +++++++ stack-8.8.2.yaml | 7 +++++++ 7 files changed, 26 insertions(+) diff --git a/stack-8.4.2.yaml b/stack-8.4.2.yaml index 8ce35b2f4..66746665f 100644 --- a/stack-8.4.2.yaml +++ b/stack-8.4.2.yaml @@ -3,6 +3,7 @@ resolver: nightly-2018-05-30 # last nightly for GHC 8.4.2 packages: - '.' - ./haskell-lsp-types +- ./func-test extra-deps: - rope-utf16-splay-0.3.1.0 diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml index 982082203..f10f7ddd0 100644 --- a/stack-8.4.3.yaml +++ b/stack-8.4.3.yaml @@ -3,6 +3,7 @@ resolver: lts-12.5 # GHC 8.4.3 packages: - '.' - ./haskell-lsp-types +- ./func-test extra-deps: - rope-utf16-splay-0.3.1.0 diff --git a/stack-8.4.4.yaml b/stack-8.4.4.yaml index 0f8a08904..f2c049e42 100644 --- a/stack-8.4.4.yaml +++ b/stack-8.4.4.yaml @@ -3,10 +3,14 @@ resolver: lts-12.26 # GHC 8.4.4 packages: - '.' - ./haskell-lsp-types +- ./func-test extra-deps: - rope-utf16-splay-0.3.1.0 - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 +- github: bubba/lsp-test + commit: e251176a4b2ff4dead7846fe5d0a4e1dbea69fd4 flags: {} extra-package-dbs: [] diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 2cd138514..d4be31616 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -3,6 +3,7 @@ resolver: lts-13.16 # GHC 8.6.4 packages: - '.' - ./haskell-lsp-types +- ./func-test extra-deps: - rope-utf16-splay-0.3.1.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index c04ae023a..4c2b7895d 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -3,8 +3,13 @@ resolver: lts-14.11 # GHC 8.6.5 packages: - '.' - ./haskell-lsp-types +- ./func-test extra-deps: +- some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 +- github: bubba/lsp-test + commit: e251176a4b2ff4dead7846fe5d0a4e1dbea69fd4 flags: {} extra-package-dbs: [] diff --git a/stack-8.8.1.yaml b/stack-8.8.1.yaml index f23e7a35e..fd3bc60ce 100644 --- a/stack-8.8.1.yaml +++ b/stack-8.8.1.yaml @@ -3,8 +3,15 @@ resolver: nightly-2020-01-21 # last GHC 8.8.1 packages: - '.' - ./haskell-lsp-types +- ./func-test extra-deps: +- dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 +- dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 +- constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 +- dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 +- github: bubba/lsp-test + commit: e251176a4b2ff4dead7846fe5d0a4e1dbea69fd4 flags: {} extra-package-dbs: [] diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index e985c892d..6ee882d7e 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -3,8 +3,15 @@ resolver: nightly-2020-01-31 packages: - '.' - ./haskell-lsp-types +- ./func-test extra-deps: +- dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 +- dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 +- constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 +- dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 +- github: bubba/lsp-test + commit: e251176a4b2ff4dead7846fe5d0a4e1dbea69fd4 flags: {} extra-package-dbs: [] From 3e460c7ba84af2dab30f5273aafc246da6e254b6 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 28 Sep 2020 22:55:52 +0530 Subject: [PATCH 53/63] minor fixes --- .../src/Language/Haskell/LSP/Types/Common.hs | 10 +++++----- .../src/Language/Haskell/LSP/Types/Message.hs | 2 +- src/Language/Haskell/LSP/Core.hs | 12 ++++++------ 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index e51e00417..cacde6337 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -13,20 +13,20 @@ import GHC.Generics -- | A terser, isomorphic data type for 'Either', that does not get tagged when -- converting to and from JSON. -data a |? b = L a - | R b +data a |? b = InL a + | InR b deriving (Read,Show,Eq,Ord,Generic) infixr |? instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where - toJSON (L x) = toJSON x - toJSON (R x) = toJSON x + toJSON (InL x) = toJSON x + toJSON (InR x) = toJSON x instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where -- Important: Try to parse the **rightmost** type first, as in the specification -- the more complex types tend to appear on the right of the |, i.e. -- @colorProvider?: boolean | DocumentColorOptions | DocumentColorRegistrationOptions;@ - parseJSON v = R <$> parseJSON v <|> L <$> parseJSON v + parseJSON v = InR <$> parseJSON v <|> InL <$> parseJSON v instance (NFData a, NFData b) => NFData (a |? b) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index cefc2aab2..2c2a11f20 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -168,7 +168,7 @@ type family ResponseParams (m :: Method p Request) :: Type where ResponseParams TextDocumentCompletion = List CompletionItem |? CompletionList ResponseParams CompletionItemResolve = CompletionItem -- Language Queries - ResponseParams TextDocumentHover = Hover + ResponseParams TextDocumentHover = Maybe Hover ResponseParams TextDocumentSignatureHelp = SignatureHelp ResponseParams TextDocumentDeclaration = Location |? List Location |? List LocationLink ResponseParams TextDocumentDefinition = Location |? List Location |? List LocationLink diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index fb43ec0b8..483cc503a 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -882,7 +882,7 @@ inferServerCapabilities clientCaps o h = -- | For when we just return a simple @true@/@false@ to indicate if we -- support the capability - supportedBool = Just . J.L . supported_b + supportedBool = Just . J.InL . supported_b supported' m b | supported_b m = Just b @@ -912,10 +912,10 @@ inferServerCapabilities clientCaps o h = codeActionProvider | clientSupportsCodeActionKinds , supported_b J.STextDocumentCodeAction = Just $ - maybe (J.L True) (J.R . J.CodeActionOptions Nothing . Just . J.List) + maybe (J.InL True) (J.InR . J.CodeActionOptions Nothing . Just . J.List) (codeActionKinds o) - | supported_b J.STextDocumentCodeAction = Just (J.L True) - | otherwise = Just (J.L False) + | supported_b J.STextDocumentCodeAction = Just (J.InL True) + | otherwise = Just (J.InL False) signatureHelpProvider | supported_b J.STextDocumentSignatureHelp = Just $ @@ -943,13 +943,13 @@ inferServerCapabilities clientCaps o h = | otherwise = Nothing sync = case textDocumentSync o of - Just x -> Just (J.L x) + Just x -> Just (J.InL x) Nothing -> Nothing workspace = J.WorkspaceServerCapabilities workspaceFolder workspaceFolder = supported' J.SWorkspaceDidChangeWorkspaceFolders $ -- sign up to receive notifications - J.WorkspaceFoldersServerCapabilities (Just True) (Just (J.R True)) + J.WorkspaceFoldersServerCapabilities (Just True) (Just (J.InR True)) progressCancelHandler :: J.WorkDoneProgressCancelNotification -> LspM config () progressCancelHandler (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do From b39318024935d6bf6c03d85b98cd46b3f62067f3 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 29 Sep 2020 02:09:21 +0530 Subject: [PATCH 54/63] make Handlers a DMap --- example/Reactor.hs | 263 +++++++++++++++---------------- example/Simple.hs | 54 +++---- haskell-lsp.cabal | 4 +- src/Language/Haskell/LSP/Core.hs | 56 +++++-- test/ServerCapabilitiesSpec.hs | 2 +- 5 files changed, 198 insertions(+), 181 deletions(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 5988de03c..20482ba34 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -43,6 +43,7 @@ import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.VFS import System.Exit import System.Log.Logger +import qualified Data.Dependent.Map as DMap -- --------------------------------------------------------------------- @@ -99,7 +100,7 @@ syncOptions = J.TextDocumentSyncOptions , J._change = Just J.TdSyncIncremental , J._willSave = Just False , J._willSaveWaitUntil = Just False - , J._save = Just $ J.R $ J.SaveOptions $ Just False + , J._save = Just $ J.InR $ J.SaveOptions $ Just False } lspOptions :: Options @@ -113,11 +114,8 @@ lspOptions = def { textDocumentSync = Just syncOptions -- LSP client, so they can be sent to the backend compiler one at a time, and a -- reply sent. -data ReactorInput - = forall (m :: J.Method 'J.FromClient 'J.Request). - ReactorInputReq (J.SMethod m) (J.RequestMessage m) (Either J.ResponseError (J.ResponseParams m) -> LspM Config ()) - | forall (m :: J.Method 'J.FromClient 'J.Notification). - ReactorInputNot (J.SMethod m) (J.NotificationMessage m) +newtype ReactorInput + = ReactorAction (LspM Config ()) -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification @@ -144,140 +142,135 @@ reactor :: TChan ReactorInput -> LspM Config () reactor inp = do liftIO $ debugM "reactor" "Started the reactor" forever $ do - reactorInput <- liftIO $ atomically $ readTChan inp - case reactorInput of - ReactorInputReq method msg responder -> - case handle method of - Just f -> f msg responder - Nothing -> pure () - ReactorInputNot method msg -> - case handle method of - Just f -> f msg - Nothing -> pure () + ReactorAction act <- liftIO $ atomically $ readTChan inp + act -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as -- input into the reactor lspHandlers :: TChan ReactorInput -> Handlers Config -lspHandlers rin method = - case handle method of - Just _ -> case J.splitClientMethod method of - J.IsClientReq -> Just $ \clientMsg responder -> - liftIO $ atomically $ writeTChan rin (ReactorInputReq method clientMsg responder) - J.IsClientNot -> Just $ \clientMsg -> - liftIO $ atomically $ writeTChan rin (ReactorInputNot method clientMsg) - J.IsClientEither -> error "TODO???" - Nothing -> Nothing +lspHandlers rin = Handlers newReqHandlers newNotHandlers + where + Handlers oldReqHandlers oldNotHandlers = handle + newReqHandlers = DMap.map goRequest oldReqHandlers + newNotHandlers = DMap.map goNot oldNotHandlers + + goRequest :: forall m. ClientMessageHandler Config J.Request m -> ClientMessageHandler Config J.Request m + goRequest (ClientMessageHandler f) = ClientMessageHandler $ \msg k -> liftIO $ + atomically $ writeTChan rin $ ReactorAction (f msg k) + + goNot :: forall m. ClientMessageHandler Config J.Notification m -> ClientMessageHandler Config J.Notification m + goNot (ClientMessageHandler f) = ClientMessageHandler $ \msg -> liftIO $ + atomically $ writeTChan rin $ ReactorAction (f msg) -- | Where the actual logic resides for handling requests and notifications. -handle :: J.SMethod m -> Maybe (Handler m Config) -handle J.SInitialized = Just $ \_msg -> do - liftIO $ debugM "reactor.handle" "Processing the Initialized notification" - - -- We're initialized! Lets send a showMessageRequest now - let params = J.ShowMessageRequestParams - J.MtWarning - "What's your favourite language extension?" - (Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"]) - - void $ sendRequest J.SWindowShowMessageRequest params $ \res -> - case res of - Left e -> liftIO $ errorM "reactor.handle" $ "Got an error: " ++ show e - Right _ -> do - sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") - - -- We can dynamically register a capability once the user accepts it - sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") - - let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) - - void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do - liftIO $ debugM "reactor.handle" "Processing a textDocument/codeLens request" - let cmd = J.Command "Say hello" "lsp-hello-command" Nothing - rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right rsp) - -handle J.STextDocumentDidOpen = Just $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - fileName = J.uriToFilePath doc - liftIO $ debugM "reactor.handle" $ "Processing DidOpenTextDocument for: " ++ show fileName - sendDiagnostics (J.toNormalizedUri doc) (Just 0) - -handle J.STextDocumentDidChange = Just $ \msg -> do - let doc = msg ^. J.params - . J.textDocument - . J.uri - . to J.toNormalizedUri - liftIO $ debugM "reactor.handle" $ "Processing DidChangeTextDocument for: " ++ show doc - mdoc <- getVirtualFile doc - case mdoc of - Just (VirtualFile _version str _) -> do - liftIO $ debugM "reactor.handle" $ "Found the virtual file: " ++ show str - Nothing -> do - liftIO $ debugM "reactor.handle" $ "Didn't find anything in the VFS for: " ++ show doc - -handle J.STextDocumentDidSave = Just $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - fileName = J.uriToFilePath doc - liftIO $ debugM "reactor.handle" $ "Processing DidSaveTextDocument for: " ++ show fileName - sendDiagnostics (J.toNormalizedUri doc) Nothing - -handle J.STextDocumentRename = Just $ \req responder -> do - liftIO $ debugM "reactor.handle" "Processing a textDocument/rename request" - let params = req ^. J.params - J.Position l c = params ^. J.position - newName = params ^. J.newName - vdoc <- getVersionedTextDoc (params ^. J.textDocument) - -- Replace some text at the position with what the user entered - let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName - tde = J.TextDocumentEdit vdoc (J.List [edit]) - -- "documentChanges" field is preferred over "changes" - rsp = J.WorkspaceEdit Nothing (Just (J.List [tde])) - responder (Right rsp) - -handle J.STextDocumentHover = Just $ \req responder -> do - liftIO $ debugM "reactor.handle" "Processing a textDocument/hover request" - let J.HoverParams _doc pos _workDone = req ^. J.params - J.Position _l _c' = pos - rsp = J.Hover ms (Just range) - ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" - range = J.Range pos pos - responder (Right rsp) - -handle J.STextDocumentCodeAction = Just $ \req responder -> do - liftIO $ debugM "reactor.handle" $ "Processing a textDocument/codeAction request" - let params = req ^. J.params - doc = params ^. J.textDocument - (J.List diags) = params ^. J.context . J.diagnostics - -- makeCommand only generates commands for diagnostics whose source is us - makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] - where - title = "Apply LSP hello command:" <> head (T.lines _m) - -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above - cmd = "lsp-hello-command" - -- need 'file' and 'start_pos' - args = J.List - [ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])] - , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])] - ] - cmdparams = Just args - makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] - rsp = J.List $ map J.L $ concatMap makeCommand diags - responder (Right rsp) - -handle J.SWorkspaceExecuteCommand = Just $ \req responder -> do - liftIO $ debugM "reactor.handle" "Processing a workspace/executeCommand request" - let params = req ^. J.params - margs = params ^. J.arguments - - liftIO $ debugM "reactor.handle" $ "The arguments are: " ++ show margs - responder (Right (J.Object mempty)) -- respond to the request - - void $ withProgress "Executing some long running command" Cancellable $ \update -> - forM [(0 :: Double)..10] $ \i -> do - update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) - liftIO $ threadDelay (1 * 1000000) - - -handle _ = Nothing +handle :: Handlers Config +handle = mconcat + [ notificationHandler J.SInitialized $ \_msg -> do + liftIO $ debugM "reactor.handle" "Processing the Initialized notification" + + -- We're initialized! Lets send a showMessageRequest now + let params = J.ShowMessageRequestParams + J.MtWarning + "What's your favourite language extension?" + (Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"]) + + void $ sendRequest J.SWindowShowMessageRequest params $ \res -> + case res of + Left e -> liftIO $ errorM "reactor.handle" $ "Got an error: " ++ show e + Right _ -> do + sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") + + -- We can dynamically register a capability once the user accepts it + sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") + + let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) + + void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do + liftIO $ debugM "reactor.handle" "Processing a textDocument/codeLens request" + let cmd = J.Command "Say hello" "lsp-hello-command" Nothing + rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right rsp) + + , notificationHandler J.STextDocumentDidOpen $ \msg -> do + let doc = msg ^. J.params . J.textDocument . J.uri + fileName = J.uriToFilePath doc + liftIO $ debugM "reactor.handle" $ "Processing DidOpenTextDocument for: " ++ show fileName + sendDiagnostics (J.toNormalizedUri doc) (Just 0) + + , notificationHandler J.STextDocumentDidChange $ \msg -> do + let doc = msg ^. J.params + . J.textDocument + . J.uri + . to J.toNormalizedUri + liftIO $ debugM "reactor.handle" $ "Processing DidChangeTextDocument for: " ++ show doc + mdoc <- getVirtualFile doc + case mdoc of + Just (VirtualFile _version str _) -> do + liftIO $ debugM "reactor.handle" $ "Found the virtual file: " ++ show str + Nothing -> do + liftIO $ debugM "reactor.handle" $ "Didn't find anything in the VFS for: " ++ show doc + + , notificationHandler J.STextDocumentDidSave $ \msg -> do + let doc = msg ^. J.params . J.textDocument . J.uri + fileName = J.uriToFilePath doc + liftIO $ debugM "reactor.handle" $ "Processing DidSaveTextDocument for: " ++ show fileName + sendDiagnostics (J.toNormalizedUri doc) Nothing + + , requestHandler J.STextDocumentRename $ \req responder -> do + liftIO $ debugM "reactor.handle" "Processing a textDocument/rename request" + let params = req ^. J.params + J.Position l c = params ^. J.position + newName = params ^. J.newName + vdoc <- getVersionedTextDoc (params ^. J.textDocument) + -- Replace some text at the position with what the user entered + let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName + tde = J.TextDocumentEdit vdoc (J.List [edit]) + -- "documentChanges" field is preferred over "changes" + rsp = J.WorkspaceEdit Nothing (Just (J.List [tde])) + responder (Right rsp) + + , requestHandler J.STextDocumentHover $ \req responder -> do + liftIO $ debugM "reactor.handle" "Processing a textDocument/hover request" + let J.HoverParams _doc pos _workDone = req ^. J.params + J.Position _l _c' = pos + rsp = J.Hover ms (Just range) + ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" + range = J.Range pos pos + responder (Right $ Just rsp) + + , requestHandler J.STextDocumentCodeAction $ \req responder -> do + liftIO $ debugM "reactor.handle" $ "Processing a textDocument/codeAction request" + let params = req ^. J.params + doc = params ^. J.textDocument + (J.List diags) = params ^. J.context . J.diagnostics + -- makeCommand only generates commands for diagnostics whose source is us + makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] + where + title = "Apply LSP hello command:" <> head (T.lines _m) + -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above + cmd = "lsp-hello-command" + -- need 'file' and 'start_pos' + args = J.List + [ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])] + , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])] + ] + cmdparams = Just args + makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] + rsp = J.List $ map J.InL $ concatMap makeCommand diags + responder (Right rsp) + + , requestHandler J.SWorkspaceExecuteCommand $ \req responder -> do + liftIO $ debugM "reactor.handle" "Processing a workspace/executeCommand request" + let params = req ^. J.params + margs = params ^. J.arguments + + liftIO $ debugM "reactor.handle" $ "The arguments are: " ++ show margs + responder (Right (J.Object mempty)) -- respond to the request + + void $ withProgress "Executing some long running command" Cancellable $ \update -> + forM [(0 :: Double)..10] $ \i -> do + update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) + liftIO $ threadDelay (1 * 1000000) + ] -- --------------------------------------------------------------------- diff --git a/example/Simple.hs b/example/Simple.hs index 0232d3545..8d9a5e4a1 100644 --- a/example/Simple.hs +++ b/example/Simple.hs @@ -7,33 +7,33 @@ import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types handlers :: Handlers () -handlers SInitialized = Just $ \_not -> do - let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" - (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) - sendRequest SWindowShowMessageRequest params $ \res -> - case res of - Right (Just (MessageActionItem "Turn on")) -> do - let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) - - registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do - let cmd = Command "Say hello" "lsp-hello-command" Nothing - rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right rsp) - pure () - Right _ -> - sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") - Left err -> - sendNotification SWindowShowMessage (ShowMessageParams MtError "Something went wrong!") - pure () - -handlers STextDocumentHover = Just $ \req responder -> do - let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req - Position _l _c' = pos - rsp = Hover ms (Just range) - ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" - range = Range pos pos - responder (Right rsp) -handlers _ = Nothing +handlers = mconcat + [ notificationHandler SInitialized $ \_not -> do + let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" + (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) + sendRequest SWindowShowMessageRequest params $ \res -> + case res of + Right (Just (MessageActionItem "Turn on")) -> do + let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) + + registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do + let cmd = Command "Say hello" "lsp-hello-command" Nothing + rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right rsp) + pure () + Right _ -> + sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") + Left err -> + sendNotification SWindowShowMessage (ShowMessageParams MtError "Something went wrong!") + pure () + , requestHandler STextDocumentHover $ \req responder -> do + let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover ms (Just range) + ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" + range = Range pos pos + responder (Right $ Just rsp) + ] initCallbacks = InitializeCallbacks { onConfigurationChange = const $ pure $ Right () diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 439c73e5d..8afc53147 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -69,7 +69,7 @@ executable lsp-demo-reactor-server main-is: Reactor.hs hs-source-dirs: example default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: base >= 4.9 && < 4.15 , aeson @@ -77,6 +77,7 @@ executable lsp-demo-reactor-server , containers , directory , data-default + , dependent-map , filepath , hslogger , lens >= 4.15.2 @@ -97,6 +98,7 @@ executable lsp-demo-simple-server main-is: Simple.hs hs-source-dirs: example default-language: Haskell2010 + ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: base >= 4.9 && < 5 , data-default -- the package library. Comment this out if you want repl changes to propagate diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 483cc503a..000f7406b 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -28,8 +28,11 @@ module Language.Haskell.LSP.Core ( , InitializeCallbacks(..) -- * Handlers - , Handlers + , Handlers(..) , Handler + , notificationHandler + , requestHandler + , ClientMessageHandler(..) , Options(..) @@ -159,7 +162,21 @@ data LanguageContextEnv config = -- | A mapping from methods to the static 'Handler's that should be used to -- handle responses when they come in from the client. -type Handlers config = forall t (m :: Method FromClient t). SMethod m -> Maybe (Handler m config) +data Handlers config + = Handlers + { reqHandlers :: DMap SMethod (ClientMessageHandler config Request) + , notHandlers :: DMap SMethod (ClientMessageHandler config Notification) + } +instance Semigroup (Handlers config) where + Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2) +instance Monoid (Handlers config) where + mempty = Handlers mempty mempty + +notificationHandler :: forall (m :: Method FromClient Notification) config. SMethod m -> Handler m config -> Handlers config +notificationHandler m h = Handlers mempty (DMap.singleton m (ClientMessageHandler h)) + +requestHandler :: forall (m :: Method FromClient Request) config. SMethod m -> Handler m config -> Handlers config +requestHandler m h = Handlers (DMap.singleton m (ClientMessageHandler h)) mempty -- | The type of a handler that handles requests and notifications coming in -- from the server or client @@ -183,13 +200,13 @@ data LanguageContextState config = type ResponseMap config = IxMap LspId (Product SMethod (ServerResponseCallback config)) -type RegistrationMap (config :: Type) (t :: MethodType) = DMap SMethod (Product RegistrationId (RegistrationHandler config t)) +type RegistrationMap (config :: Type) (t :: MethodType) = DMap SMethod (Product RegistrationId (ClientMessageHandler config t)) data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text deriving Eq -newtype RegistrationHandler config (t :: MethodType) (m :: Method FromClient t) = RegistrationHandler (Handler m config) +newtype ClientMessageHandler config (t :: MethodType) (m :: Method FromClient t) = ClientMessageHandler (Handler m config) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -356,36 +373,35 @@ handle' mAction m msg = do dynReqHandlers <- getsState resRegistrationsReq dynNotHandlers <- getsState resRegistrationsNot - staticHandlers <- LspT $ asks resHandlers - let mStaticHandler = staticHandlers m + Handlers{reqHandlers, notHandlers} <- LspT $ asks resHandlers case splitClientMethod m of - IsClientNot -> case pickHandler dynNotHandlers mStaticHandler of + IsClientNot -> case pickHandler dynNotHandlers notHandlers of Just h -> h msg Nothing | SExit <- m -> exitNotificationHandler msg | otherwise -> reportMissingHandler - IsClientReq -> case pickHandler dynReqHandlers mStaticHandler of + IsClientReq -> case pickHandler dynReqHandlers reqHandlers of Just h -> h msg (mkRspCb msg) Nothing | SShutdown <- m -> shutdownRequestHandler msg (mkRspCb msg) | otherwise -> reportMissingHandler IsClientEither -> case msg of - NotMess noti -> case pickHandler dynNotHandlers mStaticHandler of + NotMess noti -> case pickHandler dynNotHandlers notHandlers of Just h -> h noti Nothing -> reportMissingHandler - ReqMess req -> case pickHandler dynReqHandlers mStaticHandler of + ReqMess req -> case pickHandler dynReqHandlers reqHandlers of Just h -> h req (mkRspCb req) Nothing -> reportMissingHandler where -- | Checks to see if there's a dynamic handler, and uses it in favour of the -- static handler, if it exists. - pickHandler :: RegistrationMap config t -> Maybe (Handler m config) -> Maybe (Handler m config) - pickHandler dynHandlerMap mStaticHandler = case (DMap.lookup m dynHandlerMap, mStaticHandler) of - (Just (Pair _ (RegistrationHandler h)), _) -> Just h - (Nothing, Just h) -> Just h + pickHandler :: RegistrationMap config t -> DMap SMethod (ClientMessageHandler config t) -> Maybe (Handler m config) + pickHandler dynHandlerMap staticHandler = case (DMap.lookup m dynHandlerMap, DMap.lookup m staticHandler) of + (Just (Pair _ (ClientMessageHandler h)), _) -> Just h + (Nothing, Just (ClientMessageHandler h)) -> Just h (Nothing, Nothing) -> Nothing -- '$/' notifications should/could be ignored by server. @@ -645,7 +661,10 @@ registerCapability :: forall (config :: Type) t (m :: Method FromClient t). registerCapability method regOpts f = do clientCaps <- LspT $ asks resClientCapabilities handlers <- LspT $ asks resHandlers - let alreadyStaticallyRegistered = isJust $ handlers method + let alreadyStaticallyRegistered = case splitClientMethod method of + IsClientNot -> DMap.member method $ notHandlers handlers + IsClientReq -> DMap.member method $ reqHandlers handlers + IsClientEither -> error "Cannot register capability for custom methods" go clientCaps alreadyStaticallyRegistered where -- If the server has already registered statically, don't dynamically register @@ -658,7 +677,7 @@ registerCapability method regOpts f = do let registration = J.Registration uuid method regOpts params = J.RegistrationParams (J.List [J.SomeRegistration registration]) regId = RegistrationId uuid - pair = Pair regId (RegistrationHandler f) + pair = Pair regId (ClientMessageHandler f) ~() <- case splitClientMethod method of IsClientNot -> modifyState $ \ctx -> @@ -892,7 +911,10 @@ inferServerCapabilities clientCaps o h = supported = Just . supported_b supported_b :: forall m. J.SClientMethod m -> Bool - supported_b m = isJust (h m) + supported_b m = case splitClientMethod m of + IsClientNot -> DMap.member m $ notHandlers h + IsClientReq -> DMap.member m $ reqHandlers h + IsClientEither -> error "capabilities depend on custom method" singleton :: a -> [a] singleton x = [x] diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs index 6d2a8846a..a31a9a383 100644 --- a/test/ServerCapabilitiesSpec.hs +++ b/test/ServerCapabilitiesSpec.hs @@ -27,7 +27,7 @@ spec = describe "server capabilities" $ do it "decodes" $ let input = "{\"hoverProvider\": true, \"colorProvider\": {\"id\": \"abc123\", \"documentSelector\": " <> documentFiltersJson <> "}}" Just caps = decode input :: Maybe ServerCapabilities - in caps ^. colorProvider `shouldBe` Just (R $ R $ DocumentColorRegistrationOptions (Just documentFilters) (Just "abc123") Nothing) + in caps ^. colorProvider `shouldBe` Just (InR $ InR $ DocumentColorRegistrationOptions (Just documentFilters) (Just "abc123") Nothing) where documentFilters = List [DocumentFilter (Just "haskell") Nothing Nothing] documentFiltersJson = "[{\"language\": \"haskell\"}]" From 1f49334db9cc54eef3203f5f50295d8f835b1f16 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 29 Sep 2020 13:42:35 +0530 Subject: [PATCH 55/63] use unliftio instead of monad-control --- example/Reactor.hs | 5 ++--- haskell-lsp.cabal | 5 ++--- src/Language/Haskell/LSP/Core.hs | 15 +++------------ 3 files changed, 7 insertions(+), 18 deletions(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 20482ba34..2e24c3397 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -22,14 +22,12 @@ To try out this server, install it with and plug it into your client of choice. -} module Main (main) where -import Control.Concurrent import Control.Concurrent.STM.TChan import qualified Control.Exception as E import Control.Lens import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM -import Control.Monad.Trans.Control import qualified Data.Aeson as J import Data.Default import qualified Data.HashMap.Strict as H @@ -44,6 +42,7 @@ import Language.Haskell.LSP.VFS import System.Exit import System.Log.Logger import qualified Data.Dependent.Map as DMap +import UnliftIO.Concurrent -- --------------------------------------------------------------------- @@ -77,7 +76,7 @@ run = flip E.catches handlers $ do sendNotification J.SWindowShowMessage $ J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) pure $ Right cfg - , doInitialize = const $ liftBaseDiscard forkIO (reactor rin) >> pure Nothing + , doInitialize = const $ forkIO (reactor rin) >> pure Nothing } flip E.finally finalProc $ do diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 8afc53147..383887b8d 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -45,7 +45,6 @@ library , haskell-lsp-types == 0.22.* , dependent-map , lens >= 4.15.2 - , monad-control , mtl , network-uri , rope-utf16-splay >= 0.3.1.0 @@ -55,9 +54,9 @@ library , temporary , text , transformers - , transformers-base , time , unordered-containers + , unliftio-core -- used for generating random uuids for dynamic registration , random , uuid >= 1.3 @@ -81,7 +80,6 @@ executable lsp-demo-reactor-server , filepath , hslogger , lens >= 4.15.2 - , monad-control , mtl , network-uri , stm @@ -89,6 +87,7 @@ executable lsp-demo-reactor-server , time , transformers , unordered-containers + , unliftio -- the package library. Comment this out if you want repl changes to propagate , haskell-lsp if !flag(demo) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 000f7406b..9606fec89 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -84,13 +84,12 @@ import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad import Control.Applicative -import Control.Monad.Base import Control.Monad.Fix import Control.Monad.IO.Class -import Control.Monad.Trans.Control import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Control.Monad.Trans.Class +import Control.Monad.IO.Unlift import Control.Lens ( (<&>), (^.), (^?), _Just ) import qualified Data.Aeson as J import qualified Data.Aeson.Types as J @@ -134,15 +133,7 @@ import System.Random -- --------------------------------------------------------------------- newtype LspT config m a = LspT { runLspT :: ReaderT (LanguageContextEnv config) m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTransControl, MonadFix) - -instance MonadBase b m => MonadBase b (LspT config m) where - liftBase = liftBaseDefault - -instance MonadBaseControl b m => MonadBaseControl b (LspT config m) where - type StM (LspT config m) a = ComposeSt (LspT config) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadUnliftIO, MonadFix) type LspM config = LspT config IO @@ -802,7 +793,7 @@ withProgressBase indefinite title cancellable f = do WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage -- Send the begin and done notifications via 'bracket_' so that they are always fired - res <- control $ \runInBase -> + res <- withRunInIO $ \runInBase -> E.bracket_ -- Send begin notification (runInBase $ sendNotification SProgress $ From 5b7023088e1c93cb829003a82ccb5241a4510afa Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 29 Sep 2020 15:01:16 +0530 Subject: [PATCH 56/63] ord for SomeLspId --- haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs index 884858168..8336d9c23 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs @@ -35,3 +35,5 @@ data SomeLspId where deriving instance Show SomeLspId instance Eq SomeLspId where SomeLspId a == SomeLspId b = toBase a == toBase b +instance Ord SomeLspId where + SomeLspId a `compare` SomeLspId b = toBase a `compare` toBase b From 47b376c3c685147ab865f7b94cb65a409733856d Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 29 Sep 2020 17:53:04 +0530 Subject: [PATCH 57/63] add toEither --- haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index cacde6337..bb4c4c9de 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -18,6 +18,10 @@ data a |? b = InL a deriving (Read,Show,Eq,Ord,Generic) infixr |? +toEither :: a |? b -> Either a b +toEither (InL a) = Left a +toEither (InR b) = Right b + instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where toJSON (InL x) = toJSON x toJSON (InR x) = toJSON x From a29e68fcd5ab15a1eaac4f82b83cc2f36894541b Mon Sep 17 00:00:00 2001 From: wz1000 Date: Tue, 29 Sep 2020 17:54:32 +0530 Subject: [PATCH 58/63] Update haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs Co-authored-by: Julien Debon --- haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs index bb4c4c9de..ef08acd09 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Common.hs @@ -34,8 +34,9 @@ instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where instance (NFData a, NFData b) => NFData (a |? b) --- | This data type is used to host a FromJSON instance for the encoding used by --- elisp, where an empty list shows up as "null" +-- | All LSP types representing a list **must** use this type rather than '[]'. +-- In particular this is necessary to change the 'FromJSON' instance to be compatible +-- with Elisp (where empty lists show up as 'null') newtype List a = List [a] deriving (Show,Read,Eq,Ord,Semigroup,Monoid,Functor,Foldable,Traversable,Generic) From 076f2f7866bd03f370e6a0e71e09123275b0305c Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 29 Sep 2020 18:08:44 +0530 Subject: [PATCH 59/63] simplify pattern matching in Messages.hs --- .../src/Language/Haskell/LSP/Types/Message.hs | 54 +++++++++---------- 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 2c2a11f20..3ad8a23f8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -441,20 +441,19 @@ parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMess parseServerMessage lookupId v@(Object o) = do case HM.lookup "method" o of Just cmd -> do - -- Request or Response - sm <- parseJSON cmd - case sm of - SomeServerMethod m -> case splitServerMethod m of - IsServerNot -> FromServerMess m <$> parseJSON v - IsServerReq -> FromServerMess m <$> parseJSON v - IsServerEither - | HM.member "id" o -- Request - , SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request)) - in FromServerMess m' <$> parseJSON v - | SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification)) - in FromServerMess m' <$> parseJSON v + -- Request or Notification + SomeServerMethod m <- parseJSON cmd + case splitServerMethod m of + IsServerNot -> FromServerMess m <$> parseJSON v + IsServerReq -> FromServerMess m <$> parseJSON v + IsServerEither + | HM.member "id" o -- Request + , SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request)) + in FromServerMess m' <$> parseJSON v + | SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification)) + in FromServerMess m' <$> parseJSON v Nothing -> do case HM.lookup "id" o of Just i' -> do @@ -469,20 +468,19 @@ parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMess parseClientMessage lookupId v@(Object o) = do case HM.lookup "method" o of Just cmd -> do - -- Request or Response - sm <- parseJSON cmd - case sm of - SomeClientMethod m -> case splitClientMethod m of - IsClientNot -> FromClientMess m <$> parseJSON v - IsClientReq -> FromClientMess m <$> parseJSON v - IsClientEither - | HM.member "id" o -- Request - , SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request)) - in FromClientMess m' <$> parseJSON v - | SCustomMethod cm <- m -> - let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification)) - in FromClientMess m' <$> parseJSON v + -- Request or Notification + SomeClientMethod m <- parseJSON cmd + case splitClientMethod m of + IsClientNot -> FromClientMess m <$> parseJSON v + IsClientReq -> FromClientMess m <$> parseJSON v + IsClientEither + | HM.member "id" o -- Request + , SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request)) + in FromClientMess m' <$> parseJSON v + | SCustomMethod cm <- m -> + let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification)) + in FromClientMess m' <$> parseJSON v Nothing -> do case HM.lookup "id" o of Just i' -> do From 343998e454d69b7698794b3adbdecfbe7c7f28a6 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 30 Sep 2020 17:36:33 +0530 Subject: [PATCH 60/63] introduce MonadLsp --- example/Reactor.hs | 43 +++-- example/Simple.hs | 20 ++- haskell-lsp.cabal | 1 + src/Language/Haskell/LSP/Control.hs | 19 +-- src/Language/Haskell/LSP/Core.hs | 249 ++++++++++++++++------------ 5 files changed, 189 insertions(+), 143 deletions(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 2e24c3397..0a784c4a4 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -24,7 +24,7 @@ and plug it into your client of choice. module Main (main) where import Control.Concurrent.STM.TChan import qualified Control.Exception as E -import Control.Lens +import Control.Lens hiding (Iso) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM @@ -41,8 +41,7 @@ import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.VFS import System.Exit import System.Log.Logger -import qualified Data.Dependent.Map as DMap -import UnliftIO.Concurrent +import Control.Concurrent -- --------------------------------------------------------------------- @@ -76,12 +75,14 @@ run = flip E.catches handlers $ do sendNotification J.SWindowShowMessage $ J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) pure $ Right cfg - , doInitialize = const $ forkIO (reactor rin) >> pure Nothing + , doInitialize = const $ forkIO (reactor rin) >> pure (Right ()) + , staticHandlers = lspHandlers rin + , interpretHandler = const $ \env -> Iso (runLspT env) liftIO } flip E.finally finalProc $ do setupLogger Nothing ["reactor"] DEBUG - CTRL.run callbacks (lspHandlers rin) lspOptions + CTRL.run callbacks lspOptions where handlers = [ E.Handler ioExcept @@ -114,7 +115,7 @@ lspOptions = def { textDocumentSync = Just syncOptions -- reply sent. newtype ReactorInput - = ReactorAction (LspM Config ()) + = ReactorAction (IO ()) -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification @@ -137,32 +138,30 @@ sendDiagnostics fileUri version = do -- | The single point that all events flow through, allowing management of state -- to stitch replies and requests together from the two asynchronous sides: lsp -- server and backend compiler -reactor :: TChan ReactorInput -> LspM Config () +reactor :: TChan ReactorInput -> IO () reactor inp = do - liftIO $ debugM "reactor" "Started the reactor" + debugM "reactor" "Started the reactor" forever $ do - ReactorAction act <- liftIO $ atomically $ readTChan inp + ReactorAction act <- atomically $ readTChan inp act -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as -- input into the reactor -lspHandlers :: TChan ReactorInput -> Handlers Config -lspHandlers rin = Handlers newReqHandlers newNotHandlers +lspHandlers :: TChan ReactorInput -> Handlers (LspM Config) +lspHandlers rin = mapHandlers goReq goNot handle where - Handlers oldReqHandlers oldNotHandlers = handle - newReqHandlers = DMap.map goRequest oldReqHandlers - newNotHandlers = DMap.map goNot oldNotHandlers + goReq :: forall (a :: J.Method J.FromClient J.Request). Handler (LspM Config) a -> Handler (LspM Config) a + goReq f = \msg k -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k) - goRequest :: forall m. ClientMessageHandler Config J.Request m -> ClientMessageHandler Config J.Request m - goRequest (ClientMessageHandler f) = ClientMessageHandler $ \msg k -> liftIO $ - atomically $ writeTChan rin $ ReactorAction (f msg k) - - goNot :: forall m. ClientMessageHandler Config J.Notification m -> ClientMessageHandler Config J.Notification m - goNot (ClientMessageHandler f) = ClientMessageHandler $ \msg -> liftIO $ - atomically $ writeTChan rin $ ReactorAction (f msg) + goNot :: forall (a :: J.Method J.FromClient J.Notification). Handler (LspM Config) a -> Handler (LspM Config) a + goNot f = \msg -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg) -- | Where the actual logic resides for handling requests and notifications. -handle :: Handlers Config +handle :: Handlers (LspM Config) handle = mconcat [ notificationHandler J.SInitialized $ \_msg -> do liftIO $ debugM "reactor.handle" "Processing the Initialized notification" diff --git a/example/Simple.hs b/example/Simple.hs index 8d9a5e4a1..fbde45c7b 100644 --- a/example/Simple.hs +++ b/example/Simple.hs @@ -5,26 +5,28 @@ import Data.Default import Language.Haskell.LSP.Control import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types +import Control.Monad.IO.Class +import qualified Data.Text as T -handlers :: Handlers () +handlers :: Handlers (LspM ()) handlers = mconcat [ notificationHandler SInitialized $ \_not -> do let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) - sendRequest SWindowShowMessageRequest params $ \res -> + _ <- sendRequest SWindowShowMessageRequest params $ \res -> case res of Right (Just (MessageActionItem "Turn on")) -> do let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) - registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do + _ <- registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] responder (Right rsp) pure () Right _ -> sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") - Left err -> - sendNotification SWindowShowMessage (ShowMessageParams MtError "Something went wrong!") + Left err -> + sendNotification SWindowShowMessage (ShowMessageParams MtError $ "Something went wrong!\n" <> T.pack (show err)) pure () , requestHandler STextDocumentHover $ \req responder -> do let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req @@ -35,9 +37,13 @@ handlers = mconcat responder (Right $ Just rsp) ] +initCallbacks :: InitializeCallbacks () initCallbacks = InitializeCallbacks { onConfigurationChange = const $ pure $ Right () - , doInitialize = const $ pure Nothing + , doInitialize = const $ pure $ Right () + , staticHandlers = handlers + , interpretHandler = const $ \env -> Iso (runLspT env) liftIO } -main = run initCallbacks handlers def +main :: IO Int +main = run initCallbacks def diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index 383887b8d..ea1c0d7d6 100644 --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -102,6 +102,7 @@ executable lsp-demo-simple-server , data-default -- the package library. Comment this out if you want repl changes to propagate , haskell-lsp + , text if !flag(demo) buildable: False diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs index b58a30132..de7a9258b 100644 --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} module Language.Haskell.LSP.Control ( @@ -36,7 +37,6 @@ run :: Core.InitializeCallbacks config -- ^ function to be called once initialize has -- been received from the client. Further message -- processing will start only after this returns. - -> Core.Handlers config -> Core.Options -- ^ File to capture the session to. -> IO Int @@ -49,10 +49,9 @@ runWithHandles :: -> Handle -- ^ Handle to write output to. -> Core.InitializeCallbacks config - -> Core.Handlers config -> Core.Options -> IO Int -- exit code -runWithHandles hin hout initializeCallbacks h o = do +runWithHandles hin hout initializeCallbacks o = do hSetBuffering hin NoBuffering hSetEncoding hin utf8 @@ -67,7 +66,7 @@ runWithHandles hin hout initializeCallbacks h o = do BSL.hPut hout out hFlush hout - runWith clientIn clientOut initializeCallbacks h o + runWith clientIn clientOut initializeCallbacks o -- | Starts listening and sending requests and responses -- using the specified I/O. @@ -77,10 +76,9 @@ runWith :: -> (BSL.ByteString -> IO ()) -- ^ Function to provide output to. -> Core.InitializeCallbacks config - -> Core.Handlers config -> Core.Options -> IO Int -- exit code -runWith clientIn clientOut initializeCallbacks h o = do +runWith clientIn clientOut initializeCallbacks o = do infoM "haskell-lsp.runWith" "\n\n\n\n\nhaskell-lsp:Starting up server ..." @@ -90,7 +88,7 @@ runWith clientIn clientOut initializeCallbacks h o = do let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg initVFS $ \vfs -> do - ioLoop clientIn initializeCallbacks vfs h o sendMsg + ioLoop clientIn initializeCallbacks vfs o sendMsg return 1 @@ -100,11 +98,10 @@ ioLoop :: IO BS.ByteString -> Core.InitializeCallbacks config -> VFS - -> Core.Handlers config -> Core.Options -> (Core.FromServerMessage -> IO ()) -> IO () -ioLoop clientIn initializeCallbacks vfs h o sendMsg = do +ioLoop clientIn initializeCallbacks vfs o sendMsg = do minitialize <- parseOne (parse parser "") case minitialize of Nothing -> pure () @@ -114,7 +111,7 @@ ioLoop clientIn initializeCallbacks vfs h o sendMsg = do errorM "haskell-lsp.ioLoop" $ "Got error while decoding initialize:\n" <> err <> "\n exiting 1 ...\n" Right initialize -> do - mInitResp <- Core.initializeRequestHandler initializeCallbacks vfs h o sendMsg initialize + mInitResp <- Core.initializeRequestHandler initializeCallbacks vfs o sendMsg initialize case mInitResp of Nothing -> pure () Just env -> loop env (parse parser remainder) @@ -144,7 +141,7 @@ ioLoop clientIn initializeCallbacks vfs h o sendMsg = do case res of Nothing -> pure () Just (msg,remainder) -> do - Core.runReaderT (Core.runLspT (Core.processMessage $ BSL.fromStrict msg)) env + Core.runLspT env $ Core.processMessage $ BSL.fromStrict msg go (parse parser remainder) parser = do diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 9606fec89..82a3ae8d7 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -18,6 +18,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} @@ -30,6 +32,8 @@ module Language.Haskell.LSP.Core ( -- * Handlers , Handlers(..) , Handler + , transmuteHandlers + , mapHandlers , notificationHandler , requestHandler , ClientMessageHandler(..) @@ -39,7 +43,10 @@ module Language.Haskell.LSP.Core ( -- * LspT and LspM , LspT(..) , LspM + , MonadLsp(..) + , runLspT , LanguageContextEnv(..) + , type (<~>)(..) , getClientCapabilities , getConfig @@ -75,7 +82,6 @@ module Language.Haskell.LSP.Core ( , setupLogger , reverseSortEdit , initializeRequestHandler - , runReaderT , FromServerMessage ) where @@ -132,15 +138,24 @@ import System.Random {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- -newtype LspT config m a = LspT { runLspT :: ReaderT (LanguageContextEnv config) m a } +newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadUnliftIO, MonadFix) +runLspT :: LanguageContextEnv config -> LspT config m a -> m a +runLspT env = flip runReaderT env . unLspT + type LspM config = LspT config IO +class MonadUnliftIO m => MonadLsp config m | m -> config where + getLspEnv :: m (LanguageContextEnv config) + +instance MonadUnliftIO m => MonadLsp config (LspT config m) where + getLspEnv = LspT ask + data LanguageContextEnv config = LanguageContextEnv - { resHandlers :: !(Handlers config) - , resParseConfig :: !(J.Value -> LspM config (Either T.Text config)) + { resHandlers :: !(Handlers IO) + , resParseConfig :: !(J.Value -> IO (Either T.Text config)) , resSendMessage :: !(FromServerMessage -> IO ()) , resState :: !(TVar (LanguageContextState config)) , resClientCapabilities :: !J.ClientCapabilities @@ -153,27 +168,45 @@ data LanguageContextEnv config = -- | A mapping from methods to the static 'Handler's that should be used to -- handle responses when they come in from the client. -data Handlers config +data Handlers m = Handlers - { reqHandlers :: DMap SMethod (ClientMessageHandler config Request) - , notHandlers :: DMap SMethod (ClientMessageHandler config Notification) + { reqHandlers :: DMap SMethod (ClientMessageHandler m Request) + , notHandlers :: DMap SMethod (ClientMessageHandler m Notification) } instance Semigroup (Handlers config) where Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2) instance Monoid (Handlers config) where mempty = Handlers mempty mempty -notificationHandler :: forall (m :: Method FromClient Notification) config. SMethod m -> Handler m config -> Handlers config +notificationHandler :: forall (m :: Method FromClient Notification) f. SMethod m -> Handler f m -> Handlers f notificationHandler m h = Handlers mempty (DMap.singleton m (ClientMessageHandler h)) -requestHandler :: forall (m :: Method FromClient Request) config. SMethod m -> Handler m config -> Handlers config +requestHandler :: forall (m :: Method FromClient Request) f. SMethod m -> Handler f m -> Handlers f requestHandler m h = Handlers (DMap.singleton m (ClientMessageHandler h)) mempty -- | The type of a handler that handles requests and notifications coming in -- from the server or client -type family Handler (m :: Method p t) (config :: Type) = (result :: Type) | result -> config t m where - Handler (m :: Method p Request) config = RequestMessage m -> (Either ResponseError (ResponseParams m) -> LspM config ()) -> LspM config () - Handler (m :: Method p Notification) config = NotificationMessage m -> LspM config () +type family Handler (f :: Type -> Type) (m :: Method p t) = (result :: Type) | result -> f t m where + Handler f (m :: Method p Request) = RequestMessage m -> (Either ResponseError (ResponseParams m) -> f ()) -> f () + Handler f (m :: Method p Notification) = NotificationMessage m -> f () + +data m <~> n + = Iso + { forward :: forall a. m a -> n a + , backward :: forall a. n a -> m a + } + +transmuteHandlers :: (m <~> n) -> Handlers m -> Handlers n +transmuteHandlers nat = mapHandlers (\i m k -> forward nat (i m (backward nat . k))) (\i m -> forward nat (i m)) + +mapHandlers + :: (forall (a :: Method FromClient Request). Handler m a -> Handler n a) + -> (forall (a :: Method FromClient Notification). Handler m a -> Handler n a) + -> Handlers m -> Handlers n +mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots' + where + reqs' = DMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs + nots' = DMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots -- | state used by the LSP dispatcher to manage the message loop data LanguageContextState config = @@ -183,21 +216,21 @@ data LanguageContextState config = , resConfig :: !(Maybe config) , resWorkspaceFolders :: ![WorkspaceFolder] , resProgressData :: !ProgressData - , resPendingResponses :: !(ResponseMap config) - , resRegistrationsNot :: !(RegistrationMap config Notification) - , resRegistrationsReq :: !(RegistrationMap config Request) + , resPendingResponses :: !ResponseMap + , resRegistrationsNot :: !(RegistrationMap Notification) + , resRegistrationsReq :: !(RegistrationMap Request) , resLspId :: !Int } -type ResponseMap config = IxMap LspId (Product SMethod (ServerResponseCallback config)) +type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) -type RegistrationMap (config :: Type) (t :: MethodType) = DMap SMethod (Product RegistrationId (ClientMessageHandler config t)) +type RegistrationMap (t :: MethodType) = DMap SMethod (Product RegistrationId (ClientMessageHandler IO t)) data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text deriving Eq -newtype ClientMessageHandler config (t :: MethodType) (m :: Method FromClient t) = ClientMessageHandler (Handler m config) +newtype ClientMessageHandler f (t :: MethodType) (m :: Method FromClient t) = ClientMessageHandler (Handler f m) data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map ProgressToken (IO ())) } @@ -208,19 +241,19 @@ data VFSData = , reverseMap :: !(Map.Map FilePath FilePath) } -modifyState :: (LanguageContextState config -> LanguageContextState config) -> LspM config () +modifyState :: MonadLsp config m => (LanguageContextState config -> LanguageContextState config) -> m () modifyState f = do - tvarDat <- LspT $ asks resState + tvarDat <- resState <$> getLspEnv liftIO $ atomically $ modifyTVar' tvarDat f -stateState :: (LanguageContextState config -> (a,LanguageContextState config)) -> LspM config a +stateState :: MonadLsp config m => (LanguageContextState config -> (a,LanguageContextState config)) -> m a stateState f = do - tvarDat <- LspT $ asks resState + tvarDat <- resState <$> getLspEnv liftIO $ atomically $ stateTVar tvarDat f -getsState :: (LanguageContextState config -> a) -> LspM config a +getsState :: MonadLsp config m => (LanguageContextState config -> a) -> m a getsState f = do - tvarDat <- LspT $ asks resState + tvarDat <- resState <$> getLspEnv liftIO $ f <$> readTVarIO tvarDat -- --------------------------------------------------------------------- @@ -283,51 +316,61 @@ data ProgressCancellable = Cancellable | NotCancellable -- | Contains all the callbacks to use for initialized the language server. -- it is parameterized over a config type variable representing the type for the -- specific configuration data the language server needs to use. -data InitializeCallbacks config = +data InitializeCallbacks config = forall m a. InitializeCallbacks - { onConfigurationChange :: J.Value -> LspM config (Either T.Text config) + { onConfigurationChange :: J.Value -> m (Either T.Text config) -- ^ @onConfigurationChange newConfig@ is called whenever the -- clients sends a message with a changed client configuration. This -- callback should return either the parsed configuration data or an error -- indicating what went wrong. The parsed configuration object will be -- stored internally and can be accessed via 'config'. - , doInitialize :: InitializeRequest -> LspM config (Maybe ResponseError) + , doInitialize :: InitializeRequest -> IO (Either ResponseError a) -- ^ Called after receiving the @initialize@ request and before returning the response. -- This callback will be invoked to offer the language server -- implementation the chance to create any processes or start new threads -- that may be necesary for the server lifecycle. -- It can also return an error in the initialization if necessary. + , staticHandlers :: Handlers m + -- ^ The actual handlers + , interpretHandler :: a -> LanguageContextEnv config -> (m <~> IO) + -- ^ How to run the handlers + -- Passed the result of 'doInitialize' as well as the LanguageContextEnv } -- | A function that a 'Handler' is passed that can be used to respond to a -- request with either an error, or the response params. -newtype ServerResponseCallback config (m :: Method FromServer Request) - = ServerResponseCallback (Either ResponseError (ResponseParams m) -> LspM config ()) +newtype ServerResponseCallback (m :: Method FromServer Request) + = ServerResponseCallback (Either ResponseError (ResponseParams m) -> IO ()) -- | Return value signals if response handler was inserted succesfully -- Might fail if the id was already in the map -addResponseHandler :: LspId m -> (Product SMethod (ServerResponseCallback config)) m -> LspM config Bool +addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool addResponseHandler lid h = do stateState $ \ctx@LanguageContextState{resPendingResponses} -> case insertIxMap lid h resPendingResponses of Just m -> (True, ctx { resPendingResponses = m}) Nothing -> (False, ctx) -sendNotification :: forall (m :: Method FromServer Notification) config. SServerMethod m -> MessageParams m -> LspM config () +sendNotification + :: forall (m :: Method FromServer Notification) f config. MonadLsp config f + => SServerMethod m + -> MessageParams m + -> f () sendNotification m params = let msg = NotificationMessage "2.0" m params in case splitServerMethod m of IsServerNot -> sendToClient $ fromServerNot msg IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg -sendRequest :: forall (m :: Method FromServer Request) config. - SServerMethod m +sendRequest :: forall (m :: Method FromServer Request) f config. MonadLsp config f + => SServerMethod m -> MessageParams m - -> (Either ResponseError (ResponseParams m) -> LspM config ()) - -> LspM config (LspId m) + -> (Either ResponseError (ResponseParams m) -> f ()) + -> f (LspId m) sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId - success <- addResponseHandler reqId (Pair m (ServerResponseCallback resHandler)) + rio <- askRunInIO + success <- addResponseHandler reqId (Pair m (ServerResponseCallback (rio . resHandler))) unless success $ error "haskell-lsp: could not send FromServer request as id is reused" let msg = RequestMessage "2.0" reqId m params @@ -364,32 +407,40 @@ handle' mAction m msg = do dynReqHandlers <- getsState resRegistrationsReq dynNotHandlers <- getsState resRegistrationsNot - Handlers{reqHandlers, notHandlers} <- LspT $ asks resHandlers + + env <- getLspEnv + let Handlers{reqHandlers, notHandlers} = resHandlers env + + let mkRspCb :: RequestMessage (m1 :: Method FromClient Request) -> Either ResponseError (ResponseParams m1) -> IO () + mkRspCb req (Left err) = runLspT env $ sendToClient $ + FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Left err) + mkRspCb req (Right rsp) = runLspT env $ sendToClient $ + FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Right rsp) case splitClientMethod m of IsClientNot -> case pickHandler dynNotHandlers notHandlers of - Just h -> h msg + Just h -> liftIO $ h msg Nothing - | SExit <- m -> exitNotificationHandler msg + | SExit <- m -> liftIO $ exitNotificationHandler msg | otherwise -> reportMissingHandler IsClientReq -> case pickHandler dynReqHandlers reqHandlers of - Just h -> h msg (mkRspCb msg) + Just h -> liftIO $ h msg (mkRspCb msg) Nothing - | SShutdown <- m -> shutdownRequestHandler msg (mkRspCb msg) + | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) | otherwise -> reportMissingHandler IsClientEither -> case msg of NotMess noti -> case pickHandler dynNotHandlers notHandlers of - Just h -> h noti + Just h -> liftIO $ h noti Nothing -> reportMissingHandler ReqMess req -> case pickHandler dynReqHandlers reqHandlers of - Just h -> h req (mkRspCb req) + Just h -> liftIO $ h req (mkRspCb req) Nothing -> reportMissingHandler where -- | Checks to see if there's a dynamic handler, and uses it in favour of the -- static handler, if it exists. - pickHandler :: RegistrationMap config t -> DMap SMethod (ClientMessageHandler config t) -> Maybe (Handler m config) + pickHandler :: RegistrationMap t -> DMap SMethod (ClientMessageHandler IO t) -> Maybe (Handler IO m) pickHandler dynHandlerMap staticHandler = case (DMap.lookup m dynHandlerMap, DMap.lookup m staticHandler) of (Just (Pair _ (ClientMessageHandler h)), _) -> Just h (Nothing, Just (ClientMessageHandler h)) -> Just h @@ -408,19 +459,11 @@ handle' mAction m msg = do | "$/" `T.isPrefixOf` method = True isOptionalNotification _ = False - -- | Makes the callback function passed to a 'Handler' - mkRspCb :: RequestMessage (m1 :: Method FromClient Request) - -> ((Either ResponseError (ResponseParams m1)) - -> LspM config ()) - mkRspCb req (Left err) = sendToClient $ - FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Left err) - mkRspCb req (Right rsp) = sendToClient $ - FromServerRsp (req ^. J.method) $ ResponseMessage "2.0" (Just (req ^. J.id)) (Right rsp) handleConfigChange :: DidChangeConfigurationNotification -> LspM config () handleConfigChange req = do parseConfig <- LspT $ asks resParseConfig - res <- parseConfig (req ^. J.params . J.settings) + res <- liftIO $ parseConfig (req ^. J.params . J.settings) case res of Left err -> do let msg = T.pack $ unwords @@ -446,15 +489,15 @@ updateWorkspaceFolders (NotificationMessage _ _ params) = do -- --------------------------------------------------------------------- -- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. -getVirtualFile :: NormalizedUri -> LspM config (Maybe VirtualFile) +getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) getVirtualFile uri = getsState $ Map.lookup uri . vfsMap . vfsData . resVFS -getVirtualFiles :: LspM config VFS +getVirtualFiles :: MonadLsp config m => m VFS getVirtualFiles = getsState $ vfsData . resVFS -- | Dump the current text for a given VFS file to a temporary file, -- and return the path to the file. -persistVirtualFile :: NormalizedUri -> LspM config (Maybe FilePath) +persistVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe FilePath) persistVirtualFile uri = do join $ stateState $ \ctx@LanguageContextState{resVFS = vfs} -> case persistFileVFS (vfsData vfs) uri of @@ -471,7 +514,7 @@ persistVirtualFile uri = do in (act, ctx{resVFS = vfs {reverseMap = revMap} }) -- | Given a text document identifier, annotate it with the latest version. -getVersionedTextDoc :: TextDocumentIdentifier -> LspM config VersionedTextDocumentIdentifier +getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier getVersionedTextDoc doc = do let uri = doc ^. J.uri mvf <- getVirtualFile (toNormalizedUri uri) @@ -483,7 +526,7 @@ getVersionedTextDoc doc = do -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map -- the temporary file name back to the original one. -reverseFileMap :: LspM config (FilePath -> FilePath) +reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath) reverseFileMap = do vfs <- getsState resVFS let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs @@ -508,9 +551,9 @@ processMessage jsonStr = do pure $ handle m mess FromClientRsp (Pair (ServerResponseCallback f) (Const newMap)) res -> do modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap }) - pure $ f (res ^. J.result) + pure $ liftIO $ f (res ^. J.result) where - parser :: ResponseMap config -> J.Value -> J.Parser (FromClientMessage' (Product (ServerResponseCallback config) (Const (ResponseMap config)))) + parser :: ResponseMap -> J.Value -> J.Parser (FromClientMessage' (Product ServerResponseCallback (Const ResponseMap))) parser rm = parseClientMessage $ \i -> let (mhandler, newMap) = pickFromIxMap i rm in (\(Pair m handler) -> (m,Pair handler (Const newMap))) <$> mhandler @@ -526,14 +569,14 @@ processMessage jsonStr = do -- --------------------------------------------------------------------- -sendToClient :: FromServerMessage -> LspM config () +sendToClient :: MonadLsp config m => FromServerMessage -> m () sendToClient msg = do - f <- LspT $ asks resSendMessage + f <- resSendMessage <$> getLspEnv liftIO $ f msg -- --------------------------------------------------------------------- -sendErrorLog :: Text -> LspM config () +sendErrorLog :: MonadLsp config m => Text -> m () sendErrorLog msg = sendToClient $ fromServerNot $ NotificationMessage "2.0" SWindowLogMessage (LogMessageParams MtError msg) @@ -551,7 +594,7 @@ initializeErrorHandler sendResp e = do -- -- Handlers -freshLspId :: LspM config Int +freshLspId :: MonadLsp config m => m Int freshLspId = do stateState $ \c -> (resLspId c, c{resLspId = resLspId c+1}) @@ -560,12 +603,11 @@ freshLspId = do initializeRequestHandler :: InitializeCallbacks config -> VFS - -> (Handlers config) -> Options -> (FromServerMessage -> IO ()) -> Message Initialize -> IO (Maybe (LanguageContextEnv config)) -initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc req = do +initializeRequestHandler InitializeCallbacks{..} vfs options sendFunc req = do let sendResp = sendFunc . FromServerRsp SInitialize flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. J.id)) $ do @@ -596,21 +638,21 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r mempty 0 - -- Launch the given process once the project root directory has been set - let env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx (params ^. J.capabilities) rootDir - -- Call the 'duringInitialization' callback to let the server kick stuff up - initializationResult <- flip runReaderT env $ runLspT $ doInitialize req + initializationResult <- liftIO $ doInitialize req + -- Launch the given process once the project root directory has been set case initializationResult of - Just errResp -> do + Left errResp -> do sendResp $ makeResponseError (req ^. J.id) errResp - Nothing -> do + pure Nothing + Right res -> do + let env = LanguageContextEnv handlers (forward interpreter . onConfigurationChange) sendFunc tvarCtx (params ^. J.capabilities) rootDir + handlers = transmuteHandlers interpreter staticHandlers + interpreter = interpretHandler res env let serverCaps = inferServerCapabilities (params ^. J.capabilities) options handlers sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult serverCaps (serverInfo options)) - - return $ Just env - + pure $ Just env where makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) @@ -619,17 +661,17 @@ initializeRequestHandler InitializeCallbacks{..} vfs handlers options sendFunc r -- | The current configuration from the client as set via the @initialize@ and -- @workspace/didChangeConfiguration@ requests. -getConfig :: LspM config (Maybe config) +getConfig :: MonadLsp config m => m (Maybe config) getConfig = getsState resConfig -getClientCapabilities :: LspM config J.ClientCapabilities -getClientCapabilities = LspT $ asks resClientCapabilities +getClientCapabilities :: MonadLsp config m => m J.ClientCapabilities +getClientCapabilities = resClientCapabilities <$> getLspEnv -getRootPath :: LspM config (Maybe FilePath) -getRootPath = LspT $ asks resRootPath +getRootPath :: MonadLsp config m => m (Maybe FilePath) +getRootPath = resRootPath <$> getLspEnv -- | The current workspace folders, if the client supports workspace folders. -getWorkspaceFolders :: LspM config (Maybe [WorkspaceFolder]) +getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) getWorkspaceFolders = do clientCaps <- getClientCapabilities let clientSupportsWfs = fromMaybe False $ do @@ -644,14 +686,14 @@ getWorkspaceFolders = do -- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not -- support dynamic registration for the specified method, otherwise a -- 'RegistrationToken' which can be used to unregister it later. -registerCapability :: forall (config :: Type) t (m :: Method FromClient t). - SClientMethod m +registerCapability :: forall f (m :: Method FromClient t) config. MonadLsp config f + => SClientMethod m -> RegistrationOptions m - -> Handler m config - -> LspM config (Maybe (RegistrationToken m)) + -> Handler f m + -> f (Maybe (RegistrationToken m)) registerCapability method regOpts f = do - clientCaps <- LspT $ asks resClientCapabilities - handlers <- LspT $ asks resHandlers + clientCaps <- resClientCapabilities <$> getLspEnv + handlers <- resHandlers <$> getLspEnv let alreadyStaticallyRegistered = case splitClientMethod method of IsClientNot -> DMap.member method $ notHandlers handlers IsClientReq -> DMap.member method $ reqHandlers handlers @@ -668,14 +710,15 @@ registerCapability method regOpts f = do let registration = J.Registration uuid method regOpts params = J.RegistrationParams (J.List [J.SomeRegistration registration]) regId = RegistrationId uuid - pair = Pair regId (ClientMessageHandler f) - + rio <- askUnliftIO ~() <- case splitClientMethod method of IsClientNot -> modifyState $ \ctx -> let newRegs = DMap.insert method pair (resRegistrationsNot ctx) + pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) in ctx { resRegistrationsNot = newRegs } IsClientReq -> modifyState $ \ctx -> let newRegs = DMap.insert method pair (resRegistrationsReq ctx) + pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) in ctx { resRegistrationsReq = newRegs } IsClientEither -> error "Cannot register capability for custom methods" @@ -725,7 +768,7 @@ registerCapability method regOpts f = do -- | Sends a @client/unregisterCapability@ request and removes the handler -- for that associated registration. -unregisterCapability :: RegistrationToken m -> LspM config () +unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do ~() <- case splitClientMethod m of IsClientReq -> do @@ -746,25 +789,25 @@ unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do -- PROGRESS -------------------------------------------------------------------------------- -storeProgress :: ProgressToken -> Async a -> LspM config () +storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m () storeProgress n a = do let f = Map.insert n (cancelWith a ProgressCancelledException) . progressCancel modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} -deleteProgress :: ProgressToken -> LspM config () +deleteProgress :: MonadLsp config m => ProgressToken -> m () deleteProgress n = do let f = Map.delete n . progressCancel modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} -- Get a new id for the progress session and make a new one -getNewProgressId :: LspM config ProgressToken +getNewProgressId :: MonadLsp config m => m ProgressToken getNewProgressId = do stateState $ \ctx@LanguageContextState{resProgressData} -> let x = progressNextId resProgressData ctx' = ctx { resProgressData = resProgressData { progressNextId = x + 1 }} in (ProgressNumericToken x, ctx') -withProgressBase :: Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> LspM c ()) -> LspM c a) -> LspM c a +withProgressBase :: MonadLsp c m => Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a withProgressBase indefinite title cancellable f = do progId <- getNewProgressId @@ -833,7 +876,7 @@ clientSupportsProgress (J.ClientCapabilities _ _ wc _) = fromMaybe False $ do -- If @cancellable@ is 'Cancellable', @f@ will be thrown a -- 'ProgressCancelledException' if the user cancels the action in -- progress. -withProgress :: Text -> ProgressCancellable -> ((ProgressAmount -> LspM config ()) -> LspM config a) -> LspM config a +withProgress :: MonadLsp c m => Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a withProgress title cancellable f = do clientCaps <- getClientCapabilities if clientSupportsProgress clientCaps @@ -844,7 +887,7 @@ withProgress title cancellable f = do -- precentage complete. -- -- @since 0.10.0.0 -withIndefiniteProgress :: Text -> ProgressCancellable -> LspM config a -> LspM config a +withIndefiniteProgress :: MonadLsp c m => Text -> ProgressCancellable -> m a -> m a withIndefiniteProgress title cancellable f = do clientCaps <- getClientCapabilities if clientSupportsProgress clientCaps @@ -854,7 +897,7 @@ withIndefiniteProgress title cancellable f = do -- | Infers the capabilities based on registered handlers, and sets the appropriate options. -- A provider should be set to Nothing if the server does not support it, unless it is a -- static option. -inferServerCapabilities :: J.ClientCapabilities -> Options -> Handlers config -> J.ServerCapabilities +inferServerCapabilities :: J.ClientCapabilities -> Options -> Handlers m -> J.ServerCapabilities inferServerCapabilities clientCaps o h = J.ServerCapabilities { J._textDocumentSync = sync @@ -971,13 +1014,13 @@ progressCancelHandler (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams Nothing -> return () Just cancelAction -> liftIO $ cancelAction -exitNotificationHandler :: Handler J.Exit c -exitNotificationHandler = \_ -> liftIO $ do +exitNotificationHandler :: Handler IO J.Exit +exitNotificationHandler = \_ -> do noticeM "haskell-lsp.exitNotificationHandler" "Got exit, exiting" exitSuccess -- | Default Shutdown handler -shutdownRequestHandler :: Handler J.Shutdown c +shutdownRequestHandler :: Handler IO J.Shutdown shutdownRequestHandler = \_req k -> do k $ Right J.Empty @@ -986,7 +1029,7 @@ shutdownRequestHandler = \_req k -> do -- | Aggregate all diagnostics pertaining to a particular version of a document, -- by source, and sends a @textDocument/publishDiagnostics@ notification with -- the total (limited by the first parameter) whenever it is updated. -publishDiagnostics :: Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> LspM config () +publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> m () publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState $ \ctx -> let ds = updateDiagnostics (resDiagnostics ctx) uri version diags ctx' = ctx{resDiagnostics = ds} @@ -1001,8 +1044,8 @@ publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState $ \c -- | Remove all diagnostics from a particular source, and send the updates to -- the client. -flushDiagnosticsBySource :: Int -- ^ Max number of diagnostics to send - -> Maybe DiagnosticSource -> LspM config () +flushDiagnosticsBySource :: MonadLsp config m => Int -- ^ Max number of diagnostics to send + -> Maybe DiagnosticSource -> m () flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState $ \ctx -> let ds = flushBySource (resDiagnostics ctx) msource ctx' = ctx {resDiagnostics = ds} From 37a7f0d96701847a8fbf55ff858784e469a25547 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 30 Sep 2020 21:03:25 +0530 Subject: [PATCH 61/63] tweaks to types --- example/Reactor.hs | 4 +-- example/Simple.hs | 4 +-- src/Language/Haskell/LSP/Core.hs | 43 ++++++++++++++++++-------------- 3 files changed, 28 insertions(+), 23 deletions(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 0a784c4a4..5d8b81e94 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -75,9 +75,9 @@ run = flip E.catches handlers $ do sendNotification J.SWindowShowMessage $ J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) pure $ Right cfg - , doInitialize = const $ forkIO (reactor rin) >> pure (Right ()) + , doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env) , staticHandlers = lspHandlers rin - , interpretHandler = const $ \env -> Iso (runLspT env) liftIO + , interpretHandler = \env -> Iso (runLspT env) liftIO } flip E.finally finalProc $ do diff --git a/example/Simple.hs b/example/Simple.hs index fbde45c7b..abff92098 100644 --- a/example/Simple.hs +++ b/example/Simple.hs @@ -40,9 +40,9 @@ handlers = mconcat initCallbacks :: InitializeCallbacks () initCallbacks = InitializeCallbacks { onConfigurationChange = const $ pure $ Right () - , doInitialize = const $ pure $ Right () + , doInitialize = \env _req -> pure $ Right env , staticHandlers = handlers - , interpretHandler = const $ \env -> Iso (runLspT env) liftIO + , interpretHandler = \env -> Iso (runLspT env) liftIO } main :: IO Int diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 82a3ae8d7..05dbd6eb3 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -20,6 +20,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} @@ -131,6 +132,7 @@ import qualified System.Log.Handler.Simple as LHS import System.Log.Logger import qualified System.Log.Logger as L import System.Random +import Control.Monad.Trans.Identity -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -152,6 +154,11 @@ class MonadUnliftIO m => MonadLsp config m | m -> config where instance MonadUnliftIO m => MonadLsp config (LspT config m) where getLspEnv = LspT ask +instance MonadLsp c m => MonadLsp c (ReaderT r m) where + getLspEnv = lift getLspEnv +instance MonadLsp c m => MonadLsp c (IdentityT m) where + getLspEnv = lift getLspEnv + data LanguageContextEnv config = LanguageContextEnv { resHandlers :: !(Handlers IO) @@ -324,7 +331,7 @@ data InitializeCallbacks config = forall m a. -- callback should return either the parsed configuration data or an error -- indicating what went wrong. The parsed configuration object will be -- stored internally and can be accessed via 'config'. - , doInitialize :: InitializeRequest -> IO (Either ResponseError a) + , doInitialize :: LanguageContextEnv config -> InitializeRequest -> IO (Either ResponseError a) -- ^ Called after receiving the @initialize@ request and before returning the response. -- This callback will be invoked to offer the language server -- implementation the chance to create any processes or start new threads @@ -332,7 +339,7 @@ data InitializeCallbacks config = forall m a. -- It can also return an error in the initialization if necessary. , staticHandlers :: Handlers m -- ^ The actual handlers - , interpretHandler :: a -> LanguageContextEnv config -> (m <~> IO) + , interpretHandler :: a -> (m <~> IO) -- ^ How to run the handlers -- Passed the result of 'doInitialize' as well as the LanguageContextEnv } @@ -609,14 +616,18 @@ initializeRequestHandler -> IO (Maybe (LanguageContextEnv config)) initializeRequestHandler InitializeCallbacks{..} vfs options sendFunc req = do let sendResp = sendFunc . FromServerRsp SInitialize - flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. J.id)) $ do + handleErr (Left err) = do + sendResp $ makeResponseError (req ^. J.id) err + pure Nothing + handleErr (Right a) = pure $ Just a + flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. J.id)) $ handleErr <=< runExceptT $ mdo let params = req ^. J.params let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= uriToFilePath , params ^. J.rootPath <&> T.unpack ] - case rootDir of + liftIO $ case rootDir of Nothing -> return () Just dir -> do debugM "haskell-lsp.initializeRequestHandler" $ "Setting current dir to project root:" ++ dir @@ -626,7 +637,7 @@ initializeRequestHandler InitializeCallbacks{..} vfs options sendFunc req = do Just (List xs) -> xs Nothing -> [] - tvarCtx <- newTVarIO $ + tvarCtx <- liftIO $ newTVarIO $ LanguageContextState (VFSData vfs mempty) mempty @@ -639,20 +650,14 @@ initializeRequestHandler InitializeCallbacks{..} vfs options sendFunc req = do 0 -- Call the 'duringInitialization' callback to let the server kick stuff up - initializationResult <- liftIO $ doInitialize req - - -- Launch the given process once the project root directory has been set - case initializationResult of - Left errResp -> do - sendResp $ makeResponseError (req ^. J.id) errResp - pure Nothing - Right res -> do - let env = LanguageContextEnv handlers (forward interpreter . onConfigurationChange) sendFunc tvarCtx (params ^. J.capabilities) rootDir - handlers = transmuteHandlers interpreter staticHandlers - interpreter = interpretHandler res env - let serverCaps = inferServerCapabilities (params ^. J.capabilities) options handlers - sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult serverCaps (serverInfo options)) - pure $ Just env + let env = LanguageContextEnv handlers (forward interpreter . onConfigurationChange) sendFunc tvarCtx (params ^. J.capabilities) rootDir + handlers = transmuteHandlers interpreter staticHandlers + interpreter = interpretHandler initializationResult + initializationResult <- ExceptT $ doInitialize env req + + let serverCaps = inferServerCapabilities (params ^. J.capabilities) options handlers + liftIO $ sendResp $ makeResponseMessage (req ^. J.id) (InitializeResult serverCaps (serverInfo options)) + pure env where makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) From bb63d61b952ffbc1a97d9da9405463401512d3a8 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 2 Oct 2020 13:29:32 +0100 Subject: [PATCH 62/63] Rename Provenance to From --- .../src/Language/Haskell/LSP/Types/LspId.hs | 2 +- .../src/Language/Haskell/LSP/Types/Message.hs | 26 +++++++++---------- .../src/Language/Haskell/LSP/Types/Method.hs | 10 +++---- src/Language/Haskell/LSP/Core.hs | 9 ++++--- 4 files changed, 24 insertions(+), 23 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs index 8336d9c23..9417ab9ce 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/LspId.hs @@ -12,7 +12,7 @@ import Data.IxMap import Language.Haskell.LSP.Types.Method -- | Id used for a request, Can be either a String or an Int -data LspId (m :: Method p Request) = IdInt Int | IdString Text +data LspId (m :: Method f Request) = IdInt Int | IdString Text deriving (Show,Read,Eq,Ord) instance A.ToJSON (LspId m) where diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 3ad8a23f8..f70bd31c4 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -70,7 +70,7 @@ import GHC.Generics -- --------------------------------------------------------------------- -- | Map a method to the message payload type -type family MessageParams (m :: Method p t) :: Type where +type family MessageParams (m :: Method f t) :: Type where -- Client -- General MessageParams Initialize = InitializeParams @@ -149,7 +149,7 @@ type family MessageParams (m :: Method p t) :: Type where MessageParams CustomMethod = Value -- | Map a request method to the response payload type -type family ResponseParams (m :: Method p Request) :: Type where +type family ResponseParams (m :: Method f Request) :: Type where -- Even though the specification mentions that the result types are -- @x | y | ... | null@, they don't actually need to be wrapped in a Maybe since -- (we think) this is just to account for how the response field is always @@ -225,7 +225,7 @@ starting with '$/' it is free to ignore them if they are unknown. -} -data NotificationMessage (m :: Method p Notification) = +data NotificationMessage (m :: Method f Notification) = NotificationMessage { _jsonrpc :: Text , _method :: SMethod m @@ -241,7 +241,7 @@ instance (ToJSON (MessageParams m)) => ToJSON (NotificationMessage m) where toJSON = genericToJSON lspOptions toEncoding = genericToEncoding lspOptions -data RequestMessage (m :: Method p Request) = RequestMessage +data RequestMessage (m :: Method f Request) = RequestMessage { _jsonrpc :: Text , _id :: LspId m , _method :: SMethod m @@ -260,9 +260,9 @@ instance (ToJSON (MessageParams m), FromJSON (SMethod m)) => ToJSON (RequestMess -- | A custom message data type is needed to distinguish between -- notifications and requests, since a CustomMethod can be both! -data CustomMessage p t where - ReqMess :: RequestMessage (CustomMethod :: Method p Request) -> CustomMessage p Request - NotMess :: NotificationMessage (CustomMethod :: Method p Notification) -> CustomMessage p Notification +data CustomMessage f t where + ReqMess :: RequestMessage (CustomMethod :: Method f Request) -> CustomMessage f Request + NotMess :: NotificationMessage (CustomMethod :: Method f Notification) -> CustomMessage f Notification deriving instance Show (CustomMessage p t) @@ -332,7 +332,7 @@ data ResponseError = deriveJSON lspOptions ''ResponseError -- | Either result or error must be Just. -data ResponseMessage (m :: Method p Request) = +data ResponseMessage (m :: Method f Request) = ResponseMessage { _jsonrpc :: Text , _id :: Maybe (LspId m) @@ -373,10 +373,10 @@ instance FromJSON (ResponseParams a) => FromJSON (ResponseMessage a) where -- | Map a method to the Request/Notification type with the correct -- payload -type family Message (m :: Method p t) :: Type where - Message (CustomMethod :: Method p t) = CustomMessage p t - Message (m :: Method p Request) = RequestMessage m - Message (m :: Method p Notification) = NotificationMessage m +type family Message (m :: Method f t) :: Type where + Message (CustomMethod :: Method f t) = CustomMessage f t + Message (m :: Method f Request) = RequestMessage m + Message (m :: Method f Notification) = NotificationMessage m -- Some helpful type synonyms type ClientMessage (m :: Method FromClient t) = Message m @@ -427,7 +427,7 @@ fromClientReq :: forall (m :: Method FromClient Request). Message m ~ RequestMessage m => RequestMessage m -> FromClientMessage fromClientReq m@RequestMessage{_method=meth} = FromClientMess meth m -type LookupFunc p a = forall (m :: Method p Request). LspId m -> Maybe (SMethod m, a m) +type LookupFunc f a = forall (m :: Method f Request). LspId m -> Maybe (SMethod m, a m) {- Message Types we must handle are the following diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs index 4046749d9..6d11c567a 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Method.hs @@ -20,10 +20,10 @@ import Data.GADT.Compare.TH -- --------------------------------------------------------------------- -data Provenance = FromServer | FromClient +data From = FromServer | FromClient data MethodType = Notification | Request -data Method (p :: Provenance) (t :: MethodType) where +data Method (f :: From) (t :: MethodType) where -- Client Methods -- General Initialize :: Method FromClient Request @@ -98,13 +98,13 @@ data Method (p :: Provenance) (t :: MethodType) where TextDocumentPublishDiagnostics :: Method FromServer Notification -- Cancelling - CancelRequest :: Method p Notification + CancelRequest :: Method f Notification -- Custom -- A custom message type. It is not enforced that this starts with $/. - CustomMethod :: Method p t + CustomMethod :: Method f t -data SMethod (m :: Method p t) where +data SMethod (m :: Method f t) where SInitialize :: SMethod Initialize SInitialized :: SMethod Initialized SShutdown :: SMethod Shutdown diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 05dbd6eb3..54aba90a9 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -193,9 +193,9 @@ requestHandler m h = Handlers (DMap.singleton m (ClientMessageHandler h)) mempty -- | The type of a handler that handles requests and notifications coming in -- from the server or client -type family Handler (f :: Type -> Type) (m :: Method p t) = (result :: Type) | result -> f t m where - Handler f (m :: Method p Request) = RequestMessage m -> (Either ResponseError (ResponseParams m) -> f ()) -> f () - Handler f (m :: Method p Notification) = NotificationMessage m -> f () +type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where + Handler f (m :: Method from Request) = RequestMessage m -> (Either ResponseError (ResponseParams m) -> f ()) -> f () + Handler f (m :: Method from Notification) = NotificationMessage m -> f () data m <~> n = Iso @@ -691,7 +691,8 @@ getWorkspaceFolders = do -- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not -- support dynamic registration for the specified method, otherwise a -- 'RegistrationToken' which can be used to unregister it later. -registerCapability :: forall f (m :: Method FromClient t) config. MonadLsp config f +registerCapability :: forall f t (m :: Method FromClient t) config. + MonadLsp config f => SClientMethod m -> RegistrationOptions m -> Handler f m From 487936584c7c62c4a02b76ebb7951872c6d94cfc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Fri, 2 Oct 2020 16:29:25 +0200 Subject: [PATCH 63/63] Prevent crash when log file is misconfigured --- src/Language/Haskell/LSP/Core.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 54aba90a9..c4af9f4cc 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -1076,7 +1076,7 @@ setupLogger :: Maybe FilePath -> [String] -> Priority -> IO () setupLogger mLogFile extraLogNames level = do logStream <- case mLogFile of - Just logFile -> openFile logFile AppendMode + Just logFile -> openFile logFile AppendMode `E.catch` handleIOException logFile Nothing -> return stderr hSetEncoding logStream utf8 @@ -1098,6 +1098,11 @@ setupLogger mLogFile extraLogNames level = do logFormat = "$time [$tid] $prio $loggername:\t$msg" logDateFormat = "%Y-%m-%d %H:%M:%S%Q" +handleIOException :: FilePath -> E.IOException -> IO Handle +handleIOException logFile _ = do + hPutStr stderr $ "Couldn't open log file " ++ logFile ++ "; falling back to stderr logging" + return stderr + -- --------------------------------------------------------------------- -- | The changes in a workspace edit should be applied from the end of the file