diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,6 @@ +# Revision history for haskell-lsp + +## 0.1.0.0 -- 2017-07-19 + +* First version. Implements version 3 of the Microsoft Language + Server Protocol diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Alan Zimmerman + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,52 @@ +# haskell-lsp +Haskell library for the Microsoft Language Server Protocol + +Warning: this library and its associated ecosystem is under development at the +moment. So do not have high expectations, it is not ready for casual use. + +## Hacking + +To see this library in use you need to install the [haskell-ide-engine](https://github.com/alanz/haskell-ide-engine/) + + git clone https://github.com/alanz/haskell-ide-engine + cd haskell-ide-engine + stack install + +This will put the `hie` executable in your path. + +Then, run the plugin in vscode: + + git clone https://github.com/alanz/vscode-hie-server + cd vscode-hie-server + code . + +In vscode, press F5 to run the extension in development mode. + +You can see a log from `hie` by doing + + tail -F /tmp/hie-vscode.log + +There are also facilities on the code to send back language-server-protocol log +and show events. + +It can also be used with emacs, see https://github.com/emacs-lsp/lsp-haskell + +## Using the example server + + stack install + +will generate a `lsp-hello` 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. + +Likewise, changing the executable in `lsp-haskell` for emacs. + +## Useful links + +- https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md + +## Other resource + +See #haskell-ide-engine on IRC freenode + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Control.Concurrent +import Control.Concurrent.STM.TChan +import qualified Control.Exception as E +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.STM +import Control.Monad.State +import Control.Monad.Reader +import qualified Data.Aeson as J +import Data.Default +import qualified Data.HashMap.Strict as H +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Vector as V +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.TH.DataTypesJSON 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 qualified Yi.Rope as Yi +import Control.Lens + + +-- --------------------------------------------------------------------- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +-- --------------------------------------------------------------------- +-- + +main :: IO () +main = do + run (return ()) >>= \case + 0 -> exitSuccess + c -> exitWith . ExitFailure $ c + +-- --------------------------------------------------------------------- + +run :: IO () -> IO Int +run dispatcherProc = 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 def rin + liftIO $ U.logs $ "main.run:dp tchan" + dispatcherProc + liftIO $ U.logs $ "main.run:dp after dispatcherProc" + return Nothing + + flip E.finally finalProc $ do + Core.setupLogger "/tmp/lsp-hello.log" [] L.DEBUG + CTRL.run dp (lspHandlers rin) lspOptions + + where + handlers = [ E.Handler ioExcept + , E.Handler someExcept + ] + finalProc = L.removeAllHandlers + ioExcept (e :: E.IOException) = print e >> return 1 + someExcept (e :: E.SomeException) = print e >> return 1 + +-- --------------------------------------------------------------------- + +-- 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 Core.OutMessage + -- ^ injected into the reactor input by each of the individual callback handlers + +data ReactorState = + ReactorState + { lspReqId :: !J.LspId -- ^ unique ids for requests to the client + } + +instance Default ReactorState where + def = ReactorState (J.IdInt 0) + +-- --------------------------------------------------------------------- + +-- | The monad used in the reactor +type R a = ReaderT Core.LspFuncs (StateT ReactorState IO) a + +-- --------------------------------------------------------------------- +-- reactor monad functions +-- --------------------------------------------------------------------- + +-- --------------------------------------------------------------------- + +reactorSend :: (J.ToJSON a) => a -> R () +reactorSend msg = do + lf <- ask + liftIO $ Core.sendFunc lf msg + +-- --------------------------------------------------------------------- + +publishDiagnostics :: J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> R () +publishDiagnostics uri mv diags = do + lf <- ask + liftIO $ (Core.publishDiagnosticsFunc lf) uri mv diags + +-- --------------------------------------------------------------------- + +nextLspReqId :: R J.LspId +nextLspReqId = do + s <- get + let i@(J.IdInt r) = lspReqId s + put s { lspReqId = J.IdInt (r + 1) } + return i + +-- --------------------------------------------------------------------- + +-- | 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 -> ReactorState -> TChan ReactorInput -> IO () +reactor lf st inp = do + liftIO $ U.logs $ "reactor:entered" + flip evalStateT st $ 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 (Core.RspFromClient rm) -> do + liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm + + -- ------------------------------- + + HandlerRequest (Core.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 $ 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 $ fmServerShowMessageRequest rid1 params + + -- ------------------------------- + + HandlerRequest (Core.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 doc (Just 0) + + -- ------------------------------- + + HandlerRequest (Core.NotDidChangeTextDocument notification) -> do + let doc :: J.Uri + doc = notification ^. J.params + . J.textDocument + . J.uri + mdoc <- liftIO $ Core.getVirtualFileFunc lf doc + case mdoc of + Just (VirtualFile _version str) -> do + liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf got:" ++ (show $ Yi.toString str) + Nothing -> do + liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf returned Nothing" + + liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: uri=" ++ (show doc) + + -- ------------------------------- + + HandlerRequest (Core.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 doc Nothing + + -- ------------------------------- + + HandlerRequest (Core.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 rspMsg + + -- ------------------------------- + + HandlerRequest (Core.ReqHover req) -> do + liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req + let J.TextDocumentPositionParams _doc pos = req ^. J.params + J.Position _l _c' = pos + + let + ht = J.Hover ms (Just range) + ms = J.List [J.CodeString $ J.LanguageString "lsp-hello" "TYPE INFO" ] + range = J.Range pos pos + reactorSend $ Core.makeResponseMessage req ht + + -- ------------------------------- + + HandlerRequest (Core.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 ) = [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.Array$ V.fromList + [ 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 ) = [] + let body = J.List $ concatMap makeCommand diags + reactorSend $ Core.makeResponseMessage req body + + -- ------------------------------- + + HandlerRequest (Core.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 $ 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 $ 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.Uri -> Maybe Int -> R () +sendDiagnostics fileUri mversion = do + let + diags = [J.Diagnostic + (J.Range (J.Position 0 1) (J.Position 0 5)) + (Just J.DsWarning) -- severity + Nothing -- code + (Just "lsp-hello") -- source + "Example diagnostic message" + ] + -- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r) + publishDiagnostics fileUri mversion (partitionBySource diags) + +-- --------------------------------------------------------------------- + +syncMethod :: J.TextDocumentSyncKind +syncMethod = J.TdSyncIncremental + +lspOptions :: Core.Options +lspOptions = def { Core.textDocumentSync = Just syncMethod + , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["lsp-hello-command"])) + } + +lspHandlers :: TChan ReactorInput -> Core.Handlers +lspHandlers rin + = def { Core.initializedHandler = Just $ passHandler rin Core.NotInitialized + , Core.renameHandler = Just $ passHandler rin Core.ReqRename + , Core.hoverHandler = Just $ passHandler rin Core.ReqHover + , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidOpenTextDocument + , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidSaveTextDocument + , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidChangeTextDocument + , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidCloseTextDocument + , Core.cancelNotificationHandler = Just $ passHandler rin Core.NotCancelRequest + , Core.responseHandler = Just $ responseHandlerCb rin + , Core.codeActionHandler = Just $ passHandler rin Core.ReqCodeAction + , Core.executeCommandHandler = Just $ passHandler rin Core.ReqExecuteCommand + } + +-- --------------------------------------------------------------------- + +passHandler :: TChan ReactorInput -> (a -> Core.OutMessage) -> 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 + +-- --------------------------------------------------------------------- diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal new file mode 100644 --- /dev/null +++ b/haskell-lsp.cabal @@ -0,0 +1,115 @@ +name: haskell-lsp +version: 0.1.0.0 +synopsis: Haskell library for the Microsoft Language Server Protocol + +description: An implementation of the types, and basic message server to + allow language implementors to support the Language Server + Protocol for their specific language. + . + An example of this is for Haskell via the Haskell IDE + Engine, at https://github.com//haskell-ide-engine + +homepage: https://github.com/alanz/haskell-lsp +license: MIT +license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +copyright: Alan Zimmerman, 2016 +category: Development +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 + +library + 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.TH.ClientCapabilities + , Language.Haskell.LSP.TH.Constants + , Language.Haskell.LSP.TH.DataTypesJSON + , Language.Haskell.LSP.Utility + , Language.Haskell.LSP.VFS + -- other-modules: + -- other-extensions: + ghc-options: -Wall + -- ghc-options: -Werror + build-depends: base >=4.9 && <4.10 + , aeson >=1.0.0.0 + , bytestring + , containers + , directory + , data-default + , filepath + , hslogger + , hashable + , lens >= 4.15.2 + , mtl + , parsec + , stm + , text + , time + , unordered-containers + , yi-rope + hs-source-dirs: src + default-language: Haskell2010 + +executable lsp-hello + main-is: Main.hs + hs-source-dirs: example + -- src + default-language: Haskell2010 + ghc-options: -Wall + + build-depends: base >=4.9 && <4.10 + , aeson + , bytestring + , containers + , directory + , data-default + , filepath + , hslogger + , lens >= 4.15.2 + , mtl + , parsec + , stm + , text + , time + , transformers + , unordered-containers + , vector + , yi-rope + -- the package library. Comment this out if you want repl changes to propagate + , haskell-lsp + +test-suite haskell-lsp-test + type: exitcode-stdio-1.0 + -- hs-source-dirs: test src + hs-source-dirs: test + main-is: Main.hs + other-modules: Spec + VspSpec + DiagnosticsSpec + MethodSpec + build-depends: base + , aeson + , containers + , directory + , hspec + , hashable + -- , hspec-jenkins + , lens >= 4.15.2 + , yi-rope + , haskell-lsp + -- , data-default + -- , bytestring + -- , hslogger + , text + -- , unordered-containers + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/alanz/haskell-lsp diff --git a/src/Language/Haskell/LSP/Constant.hs b/src/Language/Haskell/LSP/Constant.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Constant.hs @@ -0,0 +1,12 @@ +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" + diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Control.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.LSP.Control + ( + run + ) where + +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Monad +import Control.Monad.STM +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Monoid +import qualified Language.Haskell.LSP.Core as Core +import Language.Haskell.LSP.Utility +import System.IO +import Text.Parsec + +-- --------------------------------------------------------------------- + +run :: Core.InitializeCallback -- ^ function to be called once initialize has + -- been received from the client. Further message + -- processing will start only after this returns. + -> Core.Handlers + -> Core.Options + -> IO Int -- exit code +run dp h o = do + + logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..." + hSetBuffering stdin NoBuffering + hSetEncoding stdin utf8 + + hSetBuffering stdout NoBuffering + hSetEncoding stdout utf8 + + cout <- atomically newTChan :: IO (TChan BSL.ByteString) + _rhpid <- forkIO $ sendServer cout + + + let sendFunc :: Core.SendFunc + sendFunc str = atomically $ writeTChan cout (J.encode str) + let lf = error "LifeCycle error, ClientCapabilites not set yet via initialize maessage" + + mvarDat <- newMVar ((Core.defaultLanguageContextData h o lf :: Core.LanguageContextData) + { Core.resSendResponse = sendFunc + } ) + + ioLoop dp mvarDat + + return 1 + +-- --------------------------------------------------------------------- + +ioLoop :: Core.InitializeCallback -> MVar Core.LanguageContextData -> IO () +ioLoop dispatcherProc mvarDat = go BSL.empty + where + go :: BSL.ByteString -> IO () + go buf = do + c <- BSL.hGet stdin 1 + if c == BSL.empty + then do + logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n" + return () + else do + -- logs $ "ioLoop: got" ++ show c + let newBuf = BSL.append buf c + case readContentLength (lbs2str newBuf) of + Left _ -> go newBuf + Right len -> do + cnt <- BSL.hGet stdin len + if cnt == BSL.empty + then do + logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n" + return () + else do + logm $ (B.pack "---> ") <> cnt + Core.handleRequest dispatcherProc mvarDat newBuf cnt + ioLoop dispatcherProc mvarDat + where + readContentLength :: String -> Either ParseError Int + readContentLength = parse parser "readContentLength" + + parser = do + _ <- string "Content-Length: " + len <- manyTill digit (string _TWO_CRLF) + return . read $ len + +-- --------------------------------------------------------------------- + +-- | Simple server to make sure all stdout is serialised +sendServer :: TChan BSL.ByteString -> IO () +sendServer cstdout = do + forever $ do + str <- atomically $ readTChan cstdout + let out = BSL.concat + [ str2lbs $ "Content-Length: " ++ show (BSL.length str) + , str2lbs _TWO_CRLF + , str ] + + BSL.hPut stdout out + hFlush stdout + logm $ B.pack "<--2--" <> str + +-- | +-- +-- +_TWO_CRLF :: String +_TWO_CRLF = "\r\n\r\n" + + diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Core.hs @@ -0,0 +1,592 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.LSP.Core ( + handleRequest + , LanguageContextData(..) + , Handler + , InitializeCallback + , LspFuncs(..) + , SendFunc + , Handlers(..) + , Options(..) + , OutMessage(..) + , defaultLanguageContextData + , initializeRequestHandler + , makeResponseMessage + , makeResponseError + , setupLogger + , sendErrorResponseS + , sendErrorLogS + , sendErrorShowS + ) where + +import Control.Concurrent +import qualified Control.Exception as E +import Control.Monad +import Control.Lens ( (<&>), (^.) ) +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Default +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L +import qualified Data.Map as Map +import Data.Monoid +import qualified Data.Text as T +import Data.Text ( Text ) +import Language.Haskell.LSP.Constant +import Language.Haskell.LSP.Messages +import qualified Language.Haskell.LSP.TH.ClientCapabilities as C +import qualified Language.Haskell.LSP.TH.DataTypesJSON as J +import Language.Haskell.LSP.Utility +import Language.Haskell.LSP.VFS +import Language.Haskell.LSP.Diagnostics +import System.Directory +import System.Exit +import System.IO +import qualified System.Log.Formatter as L +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 + +-- --------------------------------------------------------------------- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +-- --------------------------------------------------------------------- + +-- | A function to send a message to the client +type SendFunc = forall a. (J.ToJSON a => a -> IO ()) + +-- | state used by the LSP dispatcher to manage the message loop +data LanguageContextData = + LanguageContextData { + resSeqDebugContextData :: !Int + , resRootPath :: !(Maybe FilePath) + , resHandlers :: !Handlers + , resOptions :: !Options + , resSendResponse :: !SendFunc + , resVFS :: !VFS + , resDiagnostics :: !DiagnosticStore + , resLspFuncs :: LspFuncs -- NOTE: Cannot be strict, lazy initialization + } + +-- --------------------------------------------------------------------- + +-- | Language Server Protocol options supported by the given language server. +-- These are automatically turned into capabilities reported to the client +-- during initialization. +data Options = + Options + { textDocumentSync :: Maybe J.TextDocumentSyncKind + , completionProvider :: Maybe J.CompletionOptions + , signatureHelpProvider :: Maybe J.SignatureHelpOptions + , codeLensProvider :: Maybe J.CodeLensOptions + , documentOnTypeFormattingProvider :: Maybe J.DocumentOnTypeFormattingOptions + , documentLinkProvider :: Maybe J.DocumentLinkOptions + , executeCommandProvider :: Maybe J.ExecuteCommandOptions + } + +instance Default Options where + def = Options 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 whenever it is +-- updated. +type PublishDiagnosticsFunc = J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> IO () + +-- | Returned to the server on startup, providing ways to interact with the client. +data LspFuncs = + LspFuncs + { clientCapabilities :: !C.ClientCapabilities + , sendFunc :: !SendFunc + , getVirtualFileFunc :: !(J.Uri -> IO (Maybe VirtualFile)) + , publishDiagnosticsFunc :: !PublishDiagnosticsFunc + } + +-- | The function in the LSP process that is called once the 'initialize' +-- message is received. Message processing will only continue once this returns, +-- so it should create whatever processes are needed. +type InitializeCallback = LspFuncs -> IO (Maybe J.ResponseError) + +-- | 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)) + , 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)) + , documentFormattingHandler :: !(Maybe (Handler J.DocumentFormattingRequest)) + , documentRangeFormattingHandler :: !(Maybe (Handler J.DocumentRangeFormattingRequest)) + , documentTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) + , renameHandler :: !(Maybe (Handler J.RenameRequest)) + -- 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.WillSaveWaitUntilTextDocumentResponse)) + + -- Notifications from the client + , didChangeConfigurationParamsHandler :: !(Maybe (Handler J.DidChangeConfigurationNotification)) + , didOpenTextDocumentNotificationHandler :: !(Maybe (Handler J.DidOpenTextDocumentNotification)) + , didChangeTextDocumentNotificationHandler :: !(Maybe (Handler J.DidChangeTextDocumentNotification)) + , didCloseTextDocumentNotificationHandler :: !(Maybe (Handler J.DidCloseTextDocumentNotification)) + , didSaveTextDocumentNotificationHandler :: !(Maybe (Handler J.DidSaveTextDocumentNotification)) + , didChangeWatchedFilesNotificationHandler :: !(Maybe (Handler J.DidChangeWatchedFilesNotification)) + -- 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 + , responseHandler :: !(Maybe (Handler J.BareResponseMessage)) + } + +instance Default Handlers where + def = Handlers Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing + +-- --------------------------------------------------------------------- +nop :: a -> b -> IO a +nop = const . return + +helper :: J.FromJSON a + => (MVar LanguageContextData -> a -> IO ()) + -> (MVar LanguageContextData -> J.Value -> IO ()) +helper requestHandler mvarDat json = + case J.fromJSON json of + J.Success req -> requestHandler mvarDat req + J.Error err -> do + let msg = T.pack . unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL + sendErrorLog mvarDat msg + +handlerMap :: InitializeCallback + -> Handlers -> J.ClientMethod -> (MVar LanguageContextData -> J.Value -> IO ()) +-- General +handlerMap i _ J.Initialize = helper (initializeRequestHandler i) +handlerMap _ h J.Initialized = hh nop $ initializedHandler h +handlerMap _ _ J.Shutdown = helper shutdownRequestHandler +handlerMap _ _ J.Exit = \_ _ -> do + logm $ B.pack "haskell-lsp:Got exit, exiting" + exitSuccess +handlerMap _ h J.CancelRequest = hh nop $ cancelNotificationHandler h +-- Workspace +handlerMap _ h J.WorkspaceDidChangeConfiguration = hh nop $ didChangeConfigurationParamsHandler h +handlerMap _ h J.WorkspaceDidChangeWatchedFiles = hh nop $ didChangeWatchedFilesNotificationHandler h +handlerMap _ h J.WorkspaceSymbol = hh nop $ workspaceSymbolHandler h +handlerMap _ h J.WorkspaceExecuteCommand = hh nop $ executeCommandHandler h +-- Document +handlerMap _ h J.TextDocumentDidOpen = hh openVFS $ didOpenTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentDidChange = hh changeVFS $ didChangeTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentWillSave = hh nop $ willSaveTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentWillSaveWaitUntil = hh nop $ willSaveWaitUntilTextDocHandler h +handlerMap _ h J.TextDocumentDidSave = hh nop $ didSaveTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentDidClose = hh closeVFS $ didCloseTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentCompletion = hh nop $ completionHandler h +handlerMap _ h J.CompletionItemResolve = hh nop $ completionResolveHandler h +handlerMap _ h J.TextDocumentHover = hh nop $ hoverHandler h +handlerMap _ h J.TextDocumentSignatureHelp = hh nop $ signatureHelpHandler h +handlerMap _ h J.TextDocumentReferences = hh nop $ referencesHandler h +handlerMap _ h J.TextDocumentDocumentHighlight = hh nop $ documentHighlightHandler h +handlerMap _ h J.TextDocumentDocumentSymbol = hh nop $ documentSymbolHandler h +handlerMap _ h J.TextDocumentFormatting = hh nop $ documentFormattingHandler h +handlerMap _ h J.TextDocumentRangeFormatting = hh nop $ documentRangeFormattingHandler h +handlerMap _ h J.TextDocumentOnTypeFormatting = hh nop $ documentTypeFormattingHandler h +handlerMap _ h J.TextDocumentDefinition = hh nop $ definitionHandler h +handlerMap _ h J.TextDocumentCodeAction = hh nop $ codeActionHandler h +handlerMap _ h J.TextDocumentCodeLens = hh nop $ codeLensHandler h +handlerMap _ h J.CodeLensResolve = hh nop $ codeLensResolveHandler h +handlerMap _ h J.TextDocumentDocumentLink = hh nop $ documentLinkHandler h +handlerMap _ h J.DocumentLinkResolve = hh nop $ documentLinkResolveHandler h +handlerMap _ h J.TextDocumentRename = hh nop $ renameHandler h +handlerMap _ _ (J.Misc x) = helper f + where f :: MVar LanguageContextData -> J.TraceNotification -> IO () + f mvarDat _ = do + let msg = "haskell-lsp:Got " ++ T.unpack x ++ " ignoring" + logm (B.pack msg) + sendErrorLog mvarDat (T.pack msg) + +-- --------------------------------------------------------------------- + +-- | Adapter from the normal handlers exposed to the library users and the +-- internal message loop +hh :: forall b. (J.FromJSON b) + => (VFS -> b -> IO VFS) -> Maybe (Handler b) -> MVar LanguageContextData -> J.Value -> IO () +hh _ Nothing = \mvarDat json -> do + let msg = T.pack $ unwords ["haskell-lsp:no handler for.", show json] + sendErrorLog mvarDat msg +hh getVfs (Just h) = \mvarDat json -> do + case J.fromJSON json of + J.Success req -> do + ctx <- readMVar mvarDat + vfs' <- getVfs (resVFS ctx) req + modifyMVar_ mvarDat (\c -> return c {resVFS = vfs'}) + h req + J.Error err -> do + let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL + sendErrorLog mvarDat msg + +-- --------------------------------------------------------------------- + +getVirtualFile :: MVar LanguageContextData -> J.Uri -> IO (Maybe VirtualFile) +getVirtualFile mvarDat uri = do + ctx <- readMVar mvarDat + return $ Map.lookup uri (resVFS ctx) + +-- --------------------------------------------------------------------- + +-- | Wrap all the protocol messages into a single type, for use in the language +-- handler in storing the original message +data OutMessage = ReqHover J.HoverRequest + | ReqCompletion J.CompletionRequest + | ReqCompletionItemResolve J.CompletionItemResolveRequest + | ReqSignatureHelp J.SignatureHelpRequest + | ReqDefinition J.DefinitionRequest + | ReqFindReferences J.ReferencesRequest + | ReqDocumentHighlights J.DocumentHighlightRequest + | ReqDocumentSymbols J.DocumentSymbolRequest + | ReqWorkspaceSymbols J.WorkspaceSymbolRequest + | ReqCodeAction J.CodeActionRequest + | ReqCodeLens J.CodeLensRequest + | ReqCodeLensResolve J.CodeLensResolveRequest + | ReqDocumentFormatting J.DocumentFormattingRequest + | ReqDocumentRangeFormatting J.DocumentRangeFormattingRequest + | ReqDocumentOnTypeFormatting J.DocumentOnTypeFormattingRequest + | ReqRename J.RenameRequest + | ReqExecuteCommand J.ExecuteCommandRequest + -- responses + | RspHover J.HoverResponse + | RspCompletion J.CompletionResponse + | RspCompletionItemResolve J.CompletionItemResolveResponse + | RspSignatureHelp J.SignatureHelpResponse + | RspDefinition J.DefinitionResponse + | RspFindReferences J.ReferencesResponse + | RspDocumentHighlights J.DocumentHighlightsResponse + | RspDocumentSymbols J.DocumentSymbolsResponse + | RspWorkspaceSymbols J.WorkspaceSymbolsResponse + | RspCodeAction J.CodeActionResponse + | RspCodeLens J.CodeLensResponse + | RspCodeLensResolve J.CodeLensResolveResponse + | RspDocumentFormatting J.DocumentFormattingResponse + | RspDocumentRangeFormatting J.DocumentRangeFormattingResponse + | RspDocumentOnTypeFormatting J.DocumentOnTypeFormattingResponse + | RspRename J.RenameResponse + | RspExecuteCommand J.ExecuteCommandResponse + + -- notifications + | NotInitialized J.InitializedNotification + | NotDidChangeConfigurationParams J.DidChangeConfigurationNotification + | NotDidOpenTextDocument J.DidOpenTextDocumentNotification + | NotDidChangeTextDocument J.DidChangeTextDocumentNotification + | NotDidCloseTextDocument J.DidCloseTextDocumentNotification + | NotDidSaveTextDocument J.DidSaveTextDocumentNotification + | NotDidChangeWatchedFiles J.DidChangeWatchedFilesNotification + + | NotCancelRequest J.CancelNotification + + | RspFromClient J.BareResponseMessage + deriving (Eq,Read,Show) + +-- --------------------------------------------------------------------- +-- | +-- +-- +_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 -> LanguageContextData +defaultLanguageContextData h o lf = LanguageContextData _INITIAL_RESPONSE_SEQUENCE Nothing h o (BSL.putStr . J.encode) mempty mempty lf + +-- --------------------------------------------------------------------- + +handleRequest :: InitializeCallback + -> MVar LanguageContextData -> BSL.ByteString -> BSL.ByteString -> IO () +handleRequest dispatcherProc mvarDat contLenStr 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 contLenStr, lbs2str jsonStr, show err] + ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) + ++ "\n" + sendErrorLog mvarDat 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 contLenStr, lbs2str jsonStr] + sendErrorLog mvarDat 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) + + where + handleResponse json = do + ctx <- readMVar mvarDat + case responseHandler $ resHandlers ctx of + Nothing -> sendErrorLog mvarDat $ 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 mvarDat msg + -- capability based handlers + handle json cmd = do + ctx <- readMVar mvarDat + let h = resHandlers ctx + handlerMap dispatcherProc h cmd mvarDat json + +-- --------------------------------------------------------------------- + +makeResponseMessage :: J.RequestMessage J.ClientMethod req resp -> resp -> J.ResponseMessage resp +makeResponseMessage req result = J.ResponseMessage "2.0" (J.responseId $ req ^. J.id) (Just result) Nothing + +makeResponseError :: J.LspIdRsp -> J.ResponseError -> J.ResponseMessage () +makeResponseError origId err = J.ResponseMessage "2.0" origId Nothing (Just err) + +-- --------------------------------------------------------------------- +-- | +-- +sendEvent :: J.ToJSON a => MVar LanguageContextData -> a -> IO () +sendEvent mvarCtx str = sendResponse mvarCtx str + +-- | +-- +sendResponse :: J.ToJSON a => MVar LanguageContextData -> a -> IO () +sendResponse mvarCtx str = do + ctx <- readMVar mvarCtx + resSendResponse ctx str + + +-- --------------------------------------------------------------------- +-- | +-- +-- +sendErrorResponse :: MVar LanguageContextData -> J.LspIdRsp -> Text -> IO () +sendErrorResponse mv origId msg = sendErrorResponseS (sendEvent mv) origId J.InternalError msg + +sendErrorResponseS :: SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO () +sendErrorResponseS sf origId err msg = do + sf $ (J.ResponseMessage "2.0" origId Nothing + (Just $ J.ResponseError err msg Nothing) :: J.ErrorResponse) + +sendErrorLog :: MVar LanguageContextData -> Text -> IO () +sendErrorLog mv msg = sendErrorLogS (sendEvent mv) msg + +sendErrorLogS :: SendFunc -> Text -> IO () +sendErrorLogS sf msg = + sf $ fmServerLogMessageNotification J.MtError msg + +-- sendErrorShow :: String -> IO () +-- sendErrorShow msg = sendErrorShowS sendEvent msg + +sendErrorShowS :: SendFunc -> Text -> IO () +sendErrorShowS sf msg = + sf $ fmServerShowMessageNotification J.MtError msg + +-- --------------------------------------------------------------------- + +defaultErrorHandlers :: (Show a) => MVar LanguageContextData -> J.LspIdRsp -> a -> [E.Handler ()] +defaultErrorHandlers mvarDat origId req = [ E.Handler someExcept ] + where + someExcept (e :: E.SomeException) = do + let msg = T.pack $ unwords ["request error.", show req, show e] + sendErrorResponse mvarDat origId msg + sendErrorLog mvarDat msg + + +-- |===================================================================== +-- +-- Handlers + +-- | +-- +initializeRequestHandler :: InitializeCallback + -> MVar LanguageContextData + -> J.InitializeRequest -> IO () +initializeRequestHandler dispatcherProc mvarCtx req@(J.RequestMessage _ origId _ params) = + flip E.catches (defaultErrorHandlers mvarCtx (J.responseId origId) req) $ do + + ctx0 <- readMVar mvarCtx + + let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= J.uriToFilePath + , params ^. J.rootPath <&> T.unpack ] + + modifyMVar_ mvarCtx (\c -> return c { resRootPath = rootDir }) + case rootDir of + Nothing -> return () + Just dir -> do + logs $ "haskell-lsp:initializeRequestHandler: setting current dir to project root:" ++ dir + unless (null dir) $ setCurrentDirectory dir + + let + getCapabilities :: J.InitializeParams -> C.ClientCapabilities + getCapabilities (J.InitializeParams _ _ _ _ c _) = c + + -- Launch the given process once the project root directory has been set + let lspFuncs = LspFuncs (getCapabilities params) + (resSendResponse ctx0) + (getVirtualFile mvarCtx) + (publishDiagnostics mvarCtx) + let ctx = ctx0 { resLspFuncs = lspFuncs } + modifyMVar_ mvarCtx (\_ -> return ctx) + + initializationResult <- dispatcherProc lspFuncs + + case initializationResult of + Just errResp -> do + sendResponse mvarCtx $ makeResponseError (J.responseId origId) errResp + + Nothing -> do + + let + h = resHandlers ctx + o = resOptions ctx + + supported (Just _) = Just True + supported Nothing = Nothing + + capa = + J.InitializeResponseCapabilitiesInner + { J._textDocumentSync = textDocumentSync o + , J._hoverProvider = supported (hoverHandler h) + , J._completionProvider = completionProvider o + , J._signatureHelpProvider = signatureHelpProvider o + , J._definitionProvider = supported (definitionHandler h) + , J._referencesProvider = supported (referencesHandler h) + , J._documentHighlightProvider = supported (documentHighlightHandler h) + + , J._documentSymbolProvider = supported (documentSymbolHandler h) + , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) + , J._codeActionProvider = supported (codeActionHandler h) + , J._codeLensProvider = codeLensProvider o + , J._documentFormattingProvider = supported (documentFormattingHandler h) + , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) + , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider o + , J._renameProvider = supported (renameHandler h) + , J._documentLinkProvider = documentLinkProvider o + , J._executeCommandProvider = executeCommandProvider o + -- TODO: Add something for experimental + , J._experimental = (Nothing :: Maybe J.Value) + } + + -- TODO: wrap this up into a fn to create a response message + res = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing + + sendResponse mvarCtx res + +-- | +-- +shutdownRequestHandler :: MVar LanguageContextData -> J.ShutdownRequest -> IO () +shutdownRequestHandler mvarCtx req@(J.RequestMessage _ origId _ _) = + flip E.catches (defaultErrorHandlers mvarCtx (J.responseId origId) req) $ do + let res = makeResponseMessage req "ok" + + sendResponse mvarCtx res + +-- --------------------------------------------------------------------- + +-- | Take the new diagnostics, update the stored diagnostics for the given file +-- and version, and publish the total to the client. +publishDiagnostics :: MVar LanguageContextData -> PublishDiagnosticsFunc +publishDiagnostics mvarDat uri mversion diags = do + ctx <- readMVar mvarDat + let ds = updateDiagnostics (resDiagnostics ctx) uri mversion diags + modifyMVar_ mvarDat (\c -> return c {resDiagnostics = ds}) + let mdp = getDiagnosticParamsFor ds uri + case mdp of + Nothing -> return () + Just params -> do + (resSendResponse ctx) $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params) + +-- |===================================================================== +-- +-- utility + + +-- | +-- Logger +-- +setupLogger :: FilePath -> [String] -> Priority -> IO () +setupLogger logFile extraLogNames level = do + + logStream <- openFile logFile AppendMode + hSetEncoding logStream utf8 + + logH <- LHS.streamHandler logStream level + + let logHandle = logH {LHS.closeFunc = hClose} + logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT + logHandler = LH.setFormatter logHandle logFormat + + L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle]) + L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler] + L.updateGlobalLogger _LOG_NAME $ 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 + diff --git a/src/Language/Haskell/LSP/Diagnostics.hs b/src/Language/Haskell/LSP/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Diagnostics.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- + +Manage the "textDocument/publishDiagnostics" notifications to keep a local copy of the +diagnostics for a particular file and version, partitioned by source. +-} +module Language.Haskell.LSP.Diagnostics + ( + DiagnosticStore + , DiagnosticsBySource + , StoreItem(..) + , partitionBySource + , updateDiagnostics + , getDiagnosticParamsFor + + -- * for tests + ) where + +import qualified Data.Map as Map +import qualified Language.Haskell.LSP.TH.DataTypesJSON as J + +-- --------------------------------------------------------------------- +{-# ANN module ("hlint: ignore Eta reduce" :: String) #-} +{-# ANN module ("hlint: ignore Redundant do" :: String) #-} +-- --------------------------------------------------------------------- + +{- +We need a three level store + + Uri : Maybe TextDocumentVersion : Maybe DiagnosticSource : [Diagnostics] + +For a given Uri, as soon as we see a new (Maybe TextDocumentVersion) we flush +all prior entries for the Uri. + +-} + +type DiagnosticStore = Map.Map J.Uri StoreItem + +data StoreItem + = StoreItem (Maybe J.TextDocumentVersion) DiagnosticsBySource + deriving (Show,Eq) + +type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) [J.Diagnostic] + +-- --------------------------------------------------------------------- + +partitionBySource :: [J.Diagnostic] -> DiagnosticsBySource +partitionBySource diags = Map.fromListWith (++) $ map (\d -> (J._source d, [d])) diags + +-- --------------------------------------------------------------------- + +updateDiagnostics :: DiagnosticStore + -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource + -> DiagnosticStore +updateDiagnostics store uri mv newDiagsBySource = r + where + newStore :: DiagnosticStore + newStore = Map.insert uri (StoreItem mv newDiagsBySource) store + + -- newDiagsBySource :: DiagnosticsBySource + -- newDiagsBySource = Map.fromListWith (++) $ map (\d -> (J._source d, [d])) diags + + updateDbs dbs = Map.insert uri new store + where + new = StoreItem mv newDbs + -- note: Map.union is left-biased, so for identical keys the first + -- argument is used + newDbs = Map.union newDiagsBySource dbs + + r = case Map.lookup uri store of + Nothing -> newStore + Just (StoreItem mvs dbs) -> + if mvs /= mv + then newStore + else updateDbs dbs + +-- --------------------------------------------------------------------- + +getDiagnosticParamsFor :: DiagnosticStore -> J.Uri -> Maybe J.PublishDiagnosticsParams +getDiagnosticParamsFor ds uri = + case Map.lookup uri ds of + Nothing -> Nothing + Just (StoreItem _ diags) -> + Just $ J.PublishDiagnosticsParams uri (J.List (concat $ Map.elems diags)) + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/LSP/Messages.hs b/src/Language/Haskell/LSP/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Messages.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.LSP.Messages ( + -- * General + fmClientInitializeRequest + , fmClientInitializedNotification + , fmClientShutdownRequest + , fmClientExitNotification + , fmClientCancelNotification + + -- * Window + , fmServerShowMessageNotification + , fmServerShowMessageRequest + , fmServerLogMessageNotification + , 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 + ) where + +import qualified Data.Aeson as J +import Data.Text ( Text ) +import qualified Language.Haskell.LSP.TH.DataTypesJSON 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) + +-- ---------------------------------------------------------------------- +-- * :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.TextDocumentPositionParams -> 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 + diff --git a/src/Language/Haskell/LSP/TH/ClientCapabilities.hs b/src/Language/Haskell/LSP/TH/ClientCapabilities.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/TH/ClientCapabilities.hs @@ -0,0 +1,641 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Language.Haskell.LSP.TH.ClientCapabilities where + +import Data.Aeson.TH +-- import Data.Aeson.Types +import qualified Data.Aeson as A +-- import qualified Data.HashMap.Strict as H +-- import qualified Data.Text as T + +import Language.Haskell.LSP.TH.Constants +-- import Language.Haskell.LSP.Utility +import Data.Default + +-- --------------------------------------------------------------------- +{- +New in 3.0 +---------- + +WorkspaceClientCapabilites + +define capabilities the editor / tool provides on the workspace: +/** + * Workspace specific client capabilities. + */ +export interface WorkspaceClientCapabilites { + /** + * 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; + }; + + /** + * Capabilities specific to the `workspace/executeCommand` request. + */ + executeCommand?: { + /** + * Execute command supports dynamic registration. + */ + dynamicRegistration?: 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 SymbolClientCapabilities = + SymbolClientCapabilities + { _dynamicRegistration :: Maybe Bool -- ^Symbol request supports dynamic + -- registration. + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''SymbolClientCapabilities) + +-- ------------------------------------- + +data ExecuteClientCapabilities = + ExecuteClientCapabilities + { _dynamicRegistration :: Maybe Bool -- ^Execute command supports dynamic + -- registration. + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''ExecuteClientCapabilities) + +-- ------------------------------------- + +data WorkspaceClientCapabilites = + WorkspaceClientCapabilites + { -- | The client supports applying batch edits to the workspace by supporting + -- the request 'workspace/applyEdit' + _applyEdit :: Maybe Bool + + -- | Capabilities specific to `WorkspaceEdit`s + , _workspaceEdit :: Maybe WorkspaceClientCapabilites + + -- | Capabilities specific to the `workspace/didChangeConfiguration` notification. + , _didChangeConfiguration :: Maybe DidChangeConfigurationClientCapabilities + + -- | Capabilities specific to the `workspace/didChangeWatchedFiles` notification. + , _didChangeWatchedFiles :: Maybe DidChangeWatchedFilesClientCapabilities + + -- | Capabilities specific to the `workspace/symbol` request. + , _symbol :: Maybe SymbolClientCapabilities + + -- | Capabilities specific to the `workspace/executeCommand` request. + , _executeCommand :: Maybe ExecuteClientCapabilities + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''WorkspaceClientCapabilites) + +instance Default WorkspaceClientCapabilites where + def = WorkspaceClientCapabilites def def def def def def + +-- --------------------------------------------------------------------- +{- +New in 3.0 +---------- + +TextDocumentClientCapabilities + define capabilities the editor / tool provides on text documents. + +/** + * 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; + } + }; + + /** + * Capabilities specific to the `textDocument/hover` + */ + hover?: { + /** + * Whether hover supports dynamic registration. + */ + dynamicRegistration?: boolean; + }; + + /** + * Capabilities specific to the `textDocument/signatureHelp` + */ + signatureHelp?: { + /** + * Whether signature help supports dynamic registration. + */ + dynamicRegistration?: boolean; + }; + + /** + * 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; + }; + + /** + * 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/codeAction` + */ + codeAction?: { + /** + * Whether code action supports dynamic registration. + */ + dynamicRegistration?: boolean; + }; + + /** + * 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/rename` + */ + rename?: { + /** + * Whether rename supports dynamic registration. + */ + dynamicRegistration?: 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 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 + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''CompletionItemClientCapabilities) + +data CompletionClientCapabilities = + CompletionClientCapabilities + { _dynamicRegistration :: Maybe Bool -- ^Whether completion supports dynamic + -- registration. + , _completionItem :: Maybe CompletionItemClientCapabilities + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''CompletionClientCapabilities) + +-- ------------------------------------- + +data HoverClientCapabilities = + HoverClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''HoverClientCapabilities) + +-- ------------------------------------- + +data SignatureHelpClientCapabilities = + SignatureHelpClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''SignatureHelpClientCapabilities) + +-- ------------------------------------- + +data ReferencesClientCapabilities = + ReferencesClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''ReferencesClientCapabilities) + +-- ------------------------------------- + +data DocumentHighlightClientCapabilities = + DocumentHighlightClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''DocumentHighlightClientCapabilities) + +-- ------------------------------------- + +data DocumentSymbolClientCapabilities = + DocumentSymbolClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''DocumentSymbolClientCapabilities) + +-- ------------------------------------- + +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 DefinitionClientCapabilities = + DefinitionClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''DefinitionClientCapabilities) + +-- ------------------------------------- + +data CodeActionClientCapabilities = + CodeActionClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''CodeActionClientCapabilities) + +-- ------------------------------------- + +data CodeLensClientCapabilities = + CodeLensClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''CodeLensClientCapabilities) + +-- ------------------------------------- + +data DocumentLinkClientCapabilities = + DocumentLinkClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''DocumentLinkClientCapabilities) + +-- ------------------------------------- + +data RenameClientCapabilities = + RenameClientCapabilities + { _dynamicRegistration :: Maybe Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''RenameClientCapabilities) + +-- ------------------------------------- + +data TextDocumentClientCapabilities = + TextDocumentClientCapabilities + { _synchronization :: Maybe SynchronizationTextDocumentClientCapabilities + + -- | Capabilities specific to the `textDocument/completion` + , _completion :: Maybe CompletionClientCapabilities + + -- | Capabilities specific to the `textDocument/hover` + , _hover :: Maybe HoverClientCapabilities + + -- | Capabilities specific to the `textDocument/signatureHelp` + , _signatureHelp :: Maybe SignatureHelpClientCapabilities + + -- | Capabilities specific to the `textDocument/references` + , _references :: Maybe ReferencesClientCapabilities + + -- | Capabilities specific to the `textDocument/documentHighlight` + , _documentHighlight :: Maybe DocumentHighlightClientCapabilities + + -- | Capabilities specific to the `textDocument/documentSymbol` + , _documentSymbol :: Maybe DocumentSymbolClientCapabilities + + -- | Capabilities specific to the `textDocument/formatting` + , _formatting :: Maybe FormattingClientCapabilities + + -- | Capabilities specific to the `textDocument/rangeFormatting` + , _rangeFormatting :: Maybe RangeFormattingClientCapabilities + + -- | Capabilities specific to the `textDocument/onTypeFormatting` + , _onTypeFormatting :: Maybe OnTypeFormattingClientCapabilities + + -- | Capabilities specific to the `textDocument/definition` + , _definition :: Maybe DefinitionClientCapabilities + + -- | Capabilities specific to the `textDocument/codeAction` + , _codeAction :: Maybe CodeActionClientCapabilities + + -- | Capabilities specific to the `textDocument/codeLens` + , _codeLens :: Maybe CodeLensClientCapabilities + + -- | Capabilities specific to the `textDocument/documentLink` + , _documentLink :: Maybe DocumentLinkClientCapabilities + + -- | Capabilities specific to the `textDocument/rename` + , _rename :: Maybe RenameClientCapabilities + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TextDocumentClientCapabilities) + +instance Default TextDocumentClientCapabilities where + def = TextDocumentClientCapabilities def def def def def def def + def def def def def def def 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?: WorkspaceClientCapabilites; + + /** + * Text document specific client capabilities. + */ + textDocument?: TextDocumentClientCapabilities; + + /** + * Experimental client capabilities. + */ + experimental?: any; +} +-} + +data ClientCapabilities = + ClientCapabilities + { _workspace :: Maybe WorkspaceClientCapabilites + , _textDocument :: Maybe TextDocumentClientCapabilities + , _experimental :: Maybe A.Object + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''ClientCapabilities) + +instance Default ClientCapabilities where + def = ClientCapabilities def def def diff --git a/src/Language/Haskell/LSP/TH/Constants.hs b/src/Language/Haskell/LSP/TH/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/TH/Constants.hs @@ -0,0 +1,17 @@ + +module Language.Haskell.LSP.TH.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/src/Language/Haskell/LSP/TH/DataTypesJSON.hs b/src/Language/Haskell/LSP/TH/DataTypesJSON.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/TH/DataTypesJSON.hs @@ -0,0 +1,4164 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.Haskell.LSP.TH.DataTypesJSON where + +import Control.Lens.TH ( makeFieldsNoPrefix ) +import Data.Aeson.TH +import Data.Aeson.Types +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as H +import Data.Hashable +import qualified Data.Text as T +import Data.Text ( Text ) +import Data.Monoid ( (<>) ) +import System.IO ( FilePath ) + +import Language.Haskell.LSP.TH.ClientCapabilities +import Language.Haskell.LSP.TH.Constants +import Language.Haskell.LSP.Utility + +-- --------------------------------------------------------------------- + +-- | 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,Monoid) + +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 + +-- --------------------------------------------------------------------- + +newtype Uri = Uri { getUri :: Text } + deriving (Eq,Ord,Read,Show,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey) + +uriToFilePath :: Uri -> Maybe FilePath +uriToFilePath (Uri uri) + | "file://" `T.isPrefixOf` uri = Just $ T.unpack $ T.drop n uri + | otherwise = Nothing + where n = T.length "file://" + +filePathToUri :: FilePath -> Uri +filePathToUri file = Uri $ T.pack $ "file://" ++ file + +-- --------------------------------------------------------------------- + +-- | 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 + +-- --------------------------------------------------------------------- + +-- | 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 + +responseId :: LspId -> LspIdRsp +responseId (IdInt i) = (IdRspInt i) +responseId (IdString s) = (IdRspString s) + +-- --------------------------------------------------------------------- + +-- Client Methods +data ClientMethod = + -- General + Initialize + | Initialized + | Shutdown + | Exit + | CancelRequest + -- Workspace + | WorkspaceDidChangeConfiguration + | WorkspaceDidChangeWatchedFiles + | WorkspaceSymbol + | WorkspaceExecuteCommand + -- Document + | TextDocumentDidOpen + | TextDocumentDidChange + | TextDocumentWillSave + | TextDocumentWillSaveWaitUntil + | TextDocumentDidSave + | TextDocumentDidClose + | TextDocumentCompletion + | CompletionItemResolve + | TextDocumentHover + | TextDocumentSignatureHelp + | TextDocumentReferences + | TextDocumentDocumentHighlight + | TextDocumentDocumentSymbol + | TextDocumentFormatting + | TextDocumentRangeFormatting + | TextDocumentOnTypeFormatting + | TextDocumentDefinition + | TextDocumentCodeAction + | TextDocumentCodeLens + | CodeLensResolve + | TextDocumentDocumentLink + | DocumentLinkResolve + | TextDocumentRename + -- Messages of the form $/message + -- Implementation Dependent, can be ignored + | Misc 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/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/references") = return TextDocumentReferences + parseJSON (A.String "textDocument/documentHighlight") = return TextDocumentDocumentHighlight + parseJSON (A.String "textDocument/documentSymbol") = return TextDocumentDocumentSymbol + 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/definition") = return TextDocumentDefinition + 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/rename") = return TextDocumentRename + parseJSON (A.String x) = if T.isPrefixOf "$/" x + then return $ Misc (T.drop 2 x) + else mempty + parseJSON _ = mempty + +instance A.ToJSON ClientMethod where + -- 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" + -- Workspace + 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 TextDocumentFormatting = A.String "textDocument/formatting" + toJSON TextDocumentRangeFormatting = A.String "textDocument/rangeFormatting" + toJSON TextDocumentOnTypeFormatting = A.String "textDocument/onTypeFormatting" + toJSON TextDocumentDefinition = A.String "textDocument/definition" + toJSON TextDocumentCodeAction = A.String "textDocument/codeAction" + toJSON TextDocumentCodeLens = A.String "textDocument/codeLens" + toJSON CodeLensResolve = A.String "codeLens/resolve" + toJSON TextDocumentRename = A.String "textDocument/rename" + toJSON TextDocumentDocumentLink = A.String "textDocument/documentLink" + toJSON DocumentLinkResolve = A.String "documentLink/resolve" + toJSON (Misc xs) = A.String $ "$/" <> xs + +data ServerMethod = + -- Window + WindowShowMessage + | WindowShowMessageRequest + | WindowLogMessage + | TelemetryEvent + -- Client + | ClientRegisterCapability + | ClientUnregisterCapability + -- Workspace + | WorkspaceApplyEdit + -- Document + | TextDocumentPublishDiagnostics + 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 "telemetry/event") = return TelemetryEvent + -- Client + parseJSON (A.String "client/registerCapability") = return ClientRegisterCapability + parseJSON (A.String "client/unregisterCapability") = return ClientUnregisterCapability + -- Workspace + parseJSON (A.String "workspace/applyEdit") = return WorkspaceApplyEdit + -- Document + parseJSON (A.String "textDocument/publishDiagnostics") = return TextDocumentPublishDiagnostics + parseJSON _ = mempty + +instance A.ToJSON ServerMethod where + -- Window + toJSON WindowShowMessage = A.String "window/showMessage" + toJSON WindowShowMessageRequest = A.String "window/showMessageRequest" + toJSON WindowLogMessage = A.String "window/logMessage" + toJSON TelemetryEvent = A.String "telemetry/event" + -- Client + toJSON ClientRegisterCapability = A.String "client/registerCapability" + toJSON ClientUnregisterCapability = A.String "client/unregisterCapability" + -- Workspace + toJSON WorkspaceApplyEdit = A.String "workspace/applyEdit" + -- Document + toJSON TextDocumentPublishDiagnostics = A.String "textDocument/publishDiagnostics" + +data RequestMessage m req resp = + RequestMessage + { _jsonrpc :: Text + , _id :: LspId + , _method :: m + , _params :: req + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''RequestMessage) +makeFieldsNoPrefix ''RequestMessage + +-- --------------------------------------------------------------------- +{- +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; +} +-} + +data ErrorCode = ParseError + | InvalidRequest + | MethodNotFound + | InvalidParams + | InternalError + -- ^ 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) + +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 _ = mempty + +-- ------------------------------------- + +data ResponseError = + ResponseError + { _code :: ErrorCode + , _message :: Text + , _xdata :: Maybe A.Value + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ResponseError) +makeFieldsNoPrefix ''ResponseError + +-- --------------------------------------------------------------------- + +data ResponseMessage a = + ResponseMessage + { _jsonrpc :: Text + , _id :: LspIdRsp + , _result :: Maybe a + , _error :: Maybe ResponseError + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''ResponseMessage) +makeFieldsNoPrefix ''ResponseMessage + +type ErrorResponse = ResponseMessage () + +-- --------------------------------------------------------------------- + +type BareResponseMessage = ResponseMessage A.Value + +-- --------------------------------------------------------------------- +{- +$ 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 a = + NotificationMessage + { _jsonrpc :: Text + , _method :: m + , _params :: a + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''NotificationMessage) +makeFieldsNoPrefix ''NotificationMessage + +-- --------------------------------------------------------------------- +{- +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 = + CancelParams + { _id :: LspId + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''CancelParams) +makeFieldsNoPrefix ''CancelParams + +type CancelNotification = NotificationMessage ClientMethod CancelParams + +-- --------------------------------------------------------------------- + +{- +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 + , _character :: Int + } deriving (Show, Read, Eq, Ord) + +$(deriveJSON lspOptions ''Position) +makeFieldsNoPrefix ''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 + } deriving (Show, Read, Eq, Ord) + +$(deriveJSON lspOptions ''Range) +makeFieldsNoPrefix ''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 + { _uri :: Uri + , _range :: Range + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''Location) +makeFieldsNoPrefix ''Location + +-- --------------------------------------------------------------------- +{- +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, + | DsInfo -- ^ Info = 3, + | DsHint -- ^ Hint = 4 + deriving (Eq,Ord,Show,Read) + +instance A.ToJSON DiagnosticSeverity where + toJSON DsError = A.Number 1 + toJSON DsWarning = A.Number 2 + toJSON DsInfo = A.Number 3 + toJSON DsHint = A.Number 4 + +instance A.FromJSON DiagnosticSeverity where + parseJSON (A.Number 1) = pure DsError + parseJSON (A.Number 2) = pure DsWarning + parseJSON (A.Number 3) = pure DsInfo + parseJSON (A.Number 4) = pure DsHint + parseJSON _ = mempty + +-- --------------------------------------------------------------------- +{- +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; +} +-} + +type DiagnosticSource = Text +data Diagnostic = + Diagnostic + { _range :: Range + , _severity :: Maybe DiagnosticSeverity + , _code :: Maybe Text -- Note: Protocol allows Int too. + , _source :: Maybe DiagnosticSource + , _message :: Text + } deriving (Show, Read, Eq, Ord) + +$(deriveJSON lspOptions ''Diagnostic) +makeFieldsNoPrefix ''Diagnostic + +-- --------------------------------------------------------------------- +{- +Command + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#command + +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. + +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 A.Value + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''Command) +makeFieldsNoPrefix ''Command + +-- --------------------------------------------------------------------- +{- +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 + { _range :: Range + , _newText :: Text + } deriving (Show,Read,Eq) + +$(deriveJSON lspOptions ''TextEdit) +makeFieldsNoPrefix ''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. + */ + version: number; +-} + +type TextDocumentVersion = Int + +data VersionedTextDocumentIdentifier = + VersionedTextDocumentIdentifier + { _uri :: Uri + , _version :: TextDocumentVersion + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''VersionedTextDocumentIdentifier) +makeFieldsNoPrefix ''VersionedTextDocumentIdentifier + +-- --------------------------------------------------------------------- +{- +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 + { _textDocument :: VersionedTextDocumentIdentifier + , _edits :: List TextEdit + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TextDocumentEdit) +makeFieldsNoPrefix ''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 `WorkspaceClientCapabilites.versionedWorkspaceEdit`. + */ + documentChanges?: TextDocumentEdit[]; +} +-} + +type WorkspaceEditMap = H.HashMap Uri (List TextEdit) + +data WorkspaceEdit = + WorkspaceEdit + { _changes :: Maybe WorkspaceEditMap + , _documentChanges :: Maybe (List TextDocumentEdit) + } deriving (Show, Read, Eq) + +instance Monoid WorkspaceEdit where + mempty = WorkspaceEdit Nothing Nothing + mappend (WorkspaceEdit a b) (WorkspaceEdit c d) = WorkspaceEdit (a <> c) (b <> d) + +$(deriveJSON lspOptions ''WorkspaceEdit) +makeFieldsNoPrefix ''WorkspaceEdit + +-- --------------------------------------------------------------------- +{- +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 + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TextDocumentIdentifier) +makeFieldsNoPrefix ''TextDocumentIdentifier + +-- --------------------------------------------------------------------- + +{- +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 + , _languageId :: Text + , _version :: Int + , _text :: Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TextDocumentItem) +makeFieldsNoPrefix ''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 + { _textDocument :: TextDocumentIdentifier + , _position :: Position + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TextDocumentPositionParams) +makeFieldsNoPrefix ''TextDocumentPositionParams + +-- --------------------------------------------------------------------- +{- +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 :: Text + , _scheme :: Text + , _pattern :: Maybe Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''DocumentFilter) +makeFieldsNoPrefix ''DocumentFilter + +{- +A document selector is the combination of one or many document filters. + +export type DocumentSelector = DocumentFilter[]; +-} +type DocumentSelector = List DocumentFilter + +-- ===================================================================== +-- 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 + } deriving (Show, Read, Eq) + + +$(deriveJSON lspOptions ''InitializeParams) +makeFieldsNoPrefix ''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) +makeFieldsNoPrefix ''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[]; +} +-} + +data CompletionOptions = + CompletionOptions + { _resolveProvider :: Maybe Bool + , _triggerCharacters :: Maybe [String] + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions {omitNothingFields = True } ''CompletionOptions) +makeFieldsNoPrefix ''CompletionOptions + +-- --------------------------------------------------------------------- +{- +/** + * Signature help options. + */ +interface SignatureHelpOptions { + /** + * The characters that trigger signature help automatically. + */ + triggerCharacters?: string[]; +-} + +data SignatureHelpOptions = + SignatureHelpOptions + { _triggerCharacters :: Maybe [String] + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''SignatureHelpOptions) +makeFieldsNoPrefix ''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) +makeFieldsNoPrefix ''CodeLensOptions + +-- --------------------------------------------------------------------- +{- +/** + * 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 [String] + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''DocumentOnTypeFormattingOptions) +makeFieldsNoPrefix ''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) +makeFieldsNoPrefix ''DocumentLinkOptions + +-- --------------------------------------------------------------------- + +{- +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) +makeFieldsNoPrefix ''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) +makeFieldsNoPrefix ''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) +makeFieldsNoPrefix ''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. + */ + 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 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. + */ + codeActionProvider?: boolean; + /** + * 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 execute command support. + */ + executeCommandProvider?: ExecuteCommandOptions; + /** + * Experimental server capabilities. + */ + experimental?: any; +} +-} + +data InitializeResponseCapabilitiesInner = + InitializeResponseCapabilitiesInner + { _textDocumentSync :: Maybe TextDocumentSyncKind + , _hoverProvider :: Maybe Bool + , _completionProvider :: Maybe CompletionOptions + , _signatureHelpProvider :: Maybe SignatureHelpOptions + , _definitionProvider :: Maybe Bool + , _referencesProvider :: Maybe Bool + , _documentHighlightProvider :: Maybe Bool + , _documentSymbolProvider :: Maybe Bool + , _workspaceSymbolProvider :: Maybe Bool + , _codeActionProvider :: Maybe Bool + , _codeLensProvider :: Maybe CodeLensOptions + , _documentFormattingProvider :: Maybe Bool + , _documentRangeFormattingProvider :: Maybe Bool + , _documentOnTypeFormattingProvider :: Maybe DocumentOnTypeFormattingOptions + , _renameProvider :: Maybe Bool + -- Following are new in 3.0 + , _documentLinkProvider :: Maybe DocumentLinkOptions + , _executeCommandProvider :: Maybe ExecuteCommandOptions + , _experimental :: Maybe A.Value + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''InitializeResponseCapabilitiesInner) +makeFieldsNoPrefix ''InitializeResponseCapabilitiesInner + + +-- --------------------------------------------------------------------- +-- | +-- Information about the capabilities of a language server +-- +data InitializeResponseCapabilities = + InitializeResponseCapabilities { + _capabilities :: InitializeResponseCapabilitiesInner + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''InitializeResponseCapabilities) +makeFieldsNoPrefix ''InitializeResponseCapabilities + +-- --------------------------------------------------------------------- + +type InitializeResponse = ResponseMessage InitializeResponseCapabilities + +type InitializeRequest = RequestMessage ClientMethod InitializeParams 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 + +type InitializedNotification = NotificationMessage ClientMethod (Maybe InitializedParams) + +-- --------------------------------------------------------------------- +{- +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. + + +-} + +type ShutdownRequest = RequestMessage ClientMethod (Maybe A.Value) Text +type ShutdownResponse = ResponseMessage Text + +-- --------------------------------------------------------------------- +{- +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 ExitNotificationParams = + ExitNotificationParams + { + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions ''ExitNotificationParams) + +type ExitNotification = NotificationMessage ClientMethod (Maybe ExitNotificationParams) + +-- --------------------------------------------------------------------- +{- +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, + | MtLog -- ^ Log = 4 + deriving (Eq,Ord,Show,Read,Enum) + +instance A.ToJSON MessageType where + toJSON MtError = A.Number 1 + toJSON MtWarning = A.Number 2 + toJSON MtInfo = A.Number 3 + toJSON MtLog = A.Number 4 + +instance A.FromJSON MessageType where + parseJSON (A.Number 1) = pure MtError + parseJSON (A.Number 2) = pure MtWarning + parseJSON (A.Number 3) = pure MtInfo + parseJSON (A.Number 4) = pure MtLog + parseJSON _ = mempty + +-- --------------------------------------- + + +data ShowMessageParams = + ShowMessageParams { + _xtype :: MessageType + , _message :: Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageParams) +makeFieldsNoPrefix ''ShowMessageParams + +type ShowMessageNotification = NotificationMessage ServerMethod 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 + { _title :: Text + } deriving (Show,Read,Eq) + +$(deriveJSON lspOptions ''MessageActionItem) +makeFieldsNoPrefix ''MessageActionItem + + +data ShowMessageRequestParams = + ShowMessageRequestParams + { _xtype :: MessageType + , _message :: Text + , _actions :: Maybe [MessageActionItem] + } deriving (Show,Read,Eq) + +$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageRequestParams) +makeFieldsNoPrefix ''ShowMessageRequestParams + +type ShowMessageRequest = RequestMessage ServerMethod ShowMessageRequestParams Text +type ShowMessageResponse = ResponseMessage Text + +-- --------------------------------------------------------------------- +{- +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 { + _xtype :: MessageType + , _message :: Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''LogMessageParams) +makeFieldsNoPrefix ''LogMessageParams + + +type LogMessageNotification = NotificationMessage ServerMethod LogMessageParams + +-- --------------------------------------------------------------------- +{- +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' +-} + + +type TelemetryNotification = NotificationMessage ServerMethod A.Value + +-- --------------------------------------------------------------------- +{- +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[]; +} +-} + +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 :: ClientMethod + + -- | Options necessary for the registration. + , _registerOptions :: Maybe A.Value + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''Registration) +makeFieldsNoPrefix ''Registration + +data RegistrationParams = + RegistrationParams + { _registrations :: List Registration + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''RegistrationParams) +makeFieldsNoPrefix ''RegistrationParams + +-- |Note: originates at the server +type RegisterCapabilityRequest = RequestMessage ServerMethod 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) +makeFieldsNoPrefix ''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. + */ +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 :: Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''Unregistration) +makeFieldsNoPrefix ''Unregistration + +data UnregistrationParams = + UnregistrationParams + { _unregistrations :: List Unregistration + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''UnregistrationParams) +makeFieldsNoPrefix ''UnregistrationParams + +type UnregisterCapabilityRequest = RequestMessage ServerMethod UnregistrationParams () + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''DidChangeConfigurationParams + + +type DidChangeConfigurationNotification = NotificationMessage ClientMethod DidChangeConfigurationParams + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''DidOpenTextDocumentParams + +type DidOpenTextDocumentNotification = NotificationMessage ClientMethod 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) +makeFieldsNoPrefix ''TextDocumentContentChangeEvent + +-- ------------------------------------- + +data DidChangeTextDocumentParams = + DidChangeTextDocumentParams + { _textDocument :: VersionedTextDocumentIdentifier + , _contentChanges :: List TextDocumentContentChangeEvent + } deriving (Show,Read,Eq) + +$(deriveJSON lspOptions ''DidChangeTextDocumentParams) +makeFieldsNoPrefix ''DidChangeTextDocumentParams + +type DidChangeTextDocumentNotification = NotificationMessage ClientMethod 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; +} +-} + +data TextDocumentChangeRegistrationOptions = + TextDocumentChangeRegistrationOptions + { _documentSelector :: Maybe DocumentSelector + , _syncKind :: TextDocumentSyncKind + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions) +makeFieldsNoPrefix ''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) +makeFieldsNoPrefix ''WillSaveTextDocumentParams + +type WillSaveTextDocumentNotification = NotificationMessage ClientMethod 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 +-} + +type WillSaveWaitUntilTextDocumentRequest = RequestMessage ClientMethod WillSaveTextDocumentParams (List TextEdit) +type WillSaveWaitUntilTextDocumentResponse = ResponseMessage (List TextEdit) + +-- --------------------------------------------------------------------- +{- +DidSaveTextDocument Notification + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#didsavetextdocument-notification + + New: The document save notification is sent from the client to the server + when the document was saved in the client. + + method: 'textDocument/didSave' + params: DidSaveTextDocumentParams defined as follows: + +interface DidSaveTextDocumentParams { + /** + * The document that was saved. + */ + textDocument: TextDocumentIdentifier; +} +-} +data DidSaveTextDocumentParams = + DidSaveTextDocumentParams + { _textDocument :: TextDocumentIdentifier + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''DidSaveTextDocumentParams) +makeFieldsNoPrefix ''DidSaveTextDocumentParams + +type DidSaveTextDocumentNotification = NotificationMessage ClientMethod DidSaveTextDocumentParams + + + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''DidCloseTextDocumentParams + + +type DidCloseTextDocumentNotification = NotificationMessage ClientMethod DidCloseTextDocumentParams + +-- --------------------------------------------------------------------- +{- +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{ fieldLabelModifier = customModifier } ''FileEvent) +makeFieldsNoPrefix ''FileEvent + +data DidChangeWatchedFilesParams = + DidChangeWatchedFilesParams + { _params :: List FileEvent + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''DidChangeWatchedFilesParams) +makeFieldsNoPrefix ''DidChangeWatchedFilesParams + + +type DidChangeWatchedFilesNotification = NotificationMessage ClientMethod 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[]; +} +-} + +data PublishDiagnosticsParams = + PublishDiagnosticsParams + { _uri :: Uri + , _diagnostics :: List Diagnostic + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''PublishDiagnosticsParams) +makeFieldsNoPrefix ''PublishDiagnosticsParams + + +type PublishDiagnosticsNotification = NotificationMessage ServerMethod PublishDiagnosticsParams + +-- --------------------------------------------------------------------- +{- +Completion Request + +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. + + 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/completion' + params: TextDocumentPositionParams +-} + +-- ------------------------------------- + +{- + +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; + /** + * 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. +-} + +-- ------------------------------------- + +data InsertTextFormat + = PlainText -- ^The primary text to be inserted is treated as a plain string. + | Snippet + -- ^ 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 + deriving (Show, Read, Eq) + +instance A.ToJSON InsertTextFormat where + toJSON PlainText = A.Number 1 + toJSON Snippet = A.Number 2 + +instance A.FromJSON InsertTextFormat where + parseJSON (A.Number 1) = pure PlainText + parseJSON (A.Number 2) = pure Snippet + parseJSON _ = mempty + +-- ------------------------------------- + +data CompletionItemKind = CiText + | CiMethod + | CiFunction + | CiConstructor + | CiField + | CiVariable + | CiClass + | CiInterface + | CiModule + | CiProperty + | CiUnit + | CiValue + | CiEnum + | CiKeyword + | CiSnippet + | CiColor + | CiFile + | CiReference + deriving (Read,Show,Eq,Ord) + +instance A.ToJSON CompletionItemKind where + toJSON CiText = A.Number 1 + toJSON CiMethod = A.Number 2 + toJSON CiFunction = A.Number 3 + toJSON CiConstructor = A.Number 4 + toJSON CiField = A.Number 5 + toJSON CiVariable = A.Number 6 + toJSON CiClass = A.Number 7 + toJSON CiInterface = A.Number 8 + toJSON CiModule = A.Number 9 + toJSON CiProperty = A.Number 10 + toJSON CiUnit = A.Number 11 + toJSON CiValue = A.Number 12 + toJSON CiEnum = A.Number 13 + toJSON CiKeyword = A.Number 14 + toJSON CiSnippet = A.Number 15 + toJSON CiColor = A.Number 16 + toJSON CiFile = A.Number 17 + toJSON CiReference = A.Number 18 + +instance A.FromJSON CompletionItemKind where + parseJSON (A.Number 1) = pure CiText + parseJSON (A.Number 2) = pure CiMethod + parseJSON (A.Number 3) = pure CiFunction + parseJSON (A.Number 4) = pure CiConstructor + parseJSON (A.Number 5) = pure CiField + parseJSON (A.Number 6) = pure CiVariable + parseJSON (A.Number 7) = pure CiClass + parseJSON (A.Number 8) = pure CiInterface + parseJSON (A.Number 9) = pure CiModule + parseJSON (A.Number 10) = pure CiProperty + parseJSON (A.Number 11) = pure CiUnit + parseJSON (A.Number 12) = pure CiValue + parseJSON (A.Number 13) = pure CiEnum + parseJSON (A.Number 14) = pure CiKeyword + parseJSON (A.Number 15) = pure CiSnippet + parseJSON (A.Number 16) = pure CiColor + parseJSON (A.Number 17) = pure CiFile + parseJSON (A.Number 18) = pure CiReference + parseJSON _ = mempty + + +-- ------------------------------------- + +data CompletionItem = + CompletionItem + { _label :: Text -- ^ The label of this completion item. By default also + -- the text that is inserted when selecting this + -- completion. + , _kind :: Maybe CompletionItemKind + , _detail :: Maybe Text -- ^ A human-readable string with additional + -- information about this item, like type or + -- symbol information. + , _documentation :: Maybe Text -- ^ A human-readable string that represents + -- a doc-comment. + , _sortText :: Maybe Text -- ^ A string that should be used when filtering + -- a set of completion items. When `falsy` the + -- label is used. + , _filterText :: Maybe Text -- ^ A string that should be used when + -- filtering a set of completion items. When + -- `falsy` the label is used. + , _insertText :: Maybe Text -- ^ A string that should be inserted a + -- document when selecting this completion. + -- When `falsy` the label is used. + , _insertTextFormat :: Maybe InsertTextFormat + -- ^ The format of the insert text. The format applies to both the + -- `insertText` property and the `newText` property of a provided + -- `textEdit`. + , _textEdit :: Maybe TextEdit + -- ^ 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. + , _additionalTextEdits :: Maybe (List TextEdit) + -- ^ 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. + , _command :: Maybe Command + -- ^ 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. + , _xdata :: Maybe A.Value -- ^ An data entry field that is preserved on a + -- completion item between a completion and a + -- completion resolve request. + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CompletionItem) +makeFieldsNoPrefix ''CompletionItem + +data CompletionListType = + CompletionListType + { _isIncomplete :: Bool + , _items :: List CompletionItem + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''CompletionListType) +makeFieldsNoPrefix ''CompletionListType + + +data CompletionResponseResult + = CompletionList CompletionListType + | Completions (List CompletionItem) + deriving (Read,Show,Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length ("CompletionResponseResult"::String)), sumEncoding = UntaggedValue } ''CompletionResponseResult) + +type CompletionResponse = ResponseMessage CompletionResponseResult +type CompletionRequest = RequestMessage ClientMethod TextDocumentPositionParams CompletionResponseResult + +-- ------------------------------------- +{- +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) +makeFieldsNoPrefix ''CompletionRegistrationOptions + +-- --------------------------------------------------------------------- +{- +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. +-} + +type CompletionItemResolveRequest = RequestMessage ClientMethod CompletionItem CompletionItem +type CompletionItemResolveResponse = ResponseMessage CompletionItem + +-- --------------------------------------------------------------------- +{- +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 defined as follows: + +/** + * The result of a hove request. + */ +interface Hover { + /** + * The hover's content + */ + contents: MarkedString | MarkedString[]; + + /** + * An optional range + */ + range?: Range; +} + +Where MarkedString is defined as follows: +/** + * 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 sematically 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. + */ +type MarkedString = string | { language: string; value: string }; + + error: code and message set in case an exception happens during the hover + request. + +Registration Options: TextDocumentRegistrationOptions + +-} + +data LanguageString = + LanguageString + { _language :: Text + , _value :: Text + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''LanguageString) +makeFieldsNoPrefix ''LanguageString + +data MarkedString = + PlainString T.Text + | CodeString LanguageString + deriving (Eq,Read,Show) + +instance ToJSON MarkedString where + toJSON (PlainString x) = toJSON x + toJSON (CodeString x) = toJSON x +instance FromJSON MarkedString where + parseJSON (A.String t) = pure $ PlainString t + parseJSON o = CodeString <$> parseJSON o + +data Hover = + Hover + { _contents :: List MarkedString + , _range :: Maybe Range + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''Hover) +makeFieldsNoPrefix ''Hover + + +type HoverRequest = RequestMessage ClientMethod TextDocumentPositionParams Hover +type HoverResponse = ResponseMessage Hover + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''ParameterInformation + + +-- ------------------------------------- + +data SignatureInformation = + SignatureInformation + { _label :: Text + , _documentation :: Maybe Text + , _parameters :: Maybe [ParameterInformation] + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''SignatureInformation) +makeFieldsNoPrefix ''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) +makeFieldsNoPrefix ''SignatureHelp + +type SignatureHelpRequest = RequestMessage ClientMethod TextDocumentPositionParams SignatureHelp +type SignatureHelpResponse = ResponseMessage 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 + { _documentSelector :: Maybe DocumentSelector + , _triggerCharacters :: Maybe (List String) + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''SignatureHelpRegistrationOptions) +makeFieldsNoPrefix ''SignatureHelpRegistrationOptions + +-- --------------------------------------------------------------------- +{- +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. + + 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/definition' + params: TextDocumentPositionParams + +Response: + + result: Location | Location[] + 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}}} + +type DefinitionRequest = RequestMessage ClientMethod TextDocumentPositionParams Location +type DefinitionResponse = ResponseMessage Location + +-- --------------------------------------------------------------------- + +{- +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) +makeFieldsNoPrefix ''ReferenceContext + + +data ReferenceParams = + ReferenceParams + { _textDocument :: TextDocumentIdentifier + , _position :: Position + , _context :: ReferenceContext + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''ReferenceParams) +makeFieldsNoPrefix ''ReferenceParams + + +type ReferencesRequest = RequestMessage ClientMethod ReferenceParams (List Location) +type ReferencesResponse = ResponseMessage (List Location) + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''DocumentHighlight + +type DocumentHighlightRequest = RequestMessage ClientMethod TextDocumentPositionParams (List DocumentHighlight) +type DocumentHighlightsResponse = ResponseMessage (List DocumentHighlight) + +-- --------------------------------------------------------------------- +{- +Document Symbols Request + +https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md#document-symbols-request + +The document symbol request is sent from the client to the server to list all +symbols found in a given text document. + + 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 + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''DocumentSymbolParams) +makeFieldsNoPrefix ''DocumentSymbolParams + +-- ------------------------------------- + +data SymbolKind + = SkFile + | SkModule + | SkNamespace + | SkPackage + | SkClass + | SkMethod + | SkProperty + | SkField + | SkConstructor + | SkEnum + | SkInterface + | SkFunction + | SkVariable + | SkConstant + | SkString + | SkNumber + | SkBoolean + | SkArray + deriving (Read,Show,Eq) + +instance A.ToJSON SymbolKind where + toJSON SkFile = A.Number 1 + toJSON SkModule = A.Number 2 + toJSON SkNamespace = A.Number 3 + toJSON SkPackage = A.Number 4 + toJSON SkClass = A.Number 5 + toJSON SkMethod = A.Number 6 + toJSON SkProperty = A.Number 7 + toJSON SkField = A.Number 8 + toJSON SkConstructor = A.Number 9 + toJSON SkEnum = A.Number 10 + toJSON SkInterface = A.Number 11 + toJSON SkFunction = A.Number 12 + toJSON SkVariable = A.Number 13 + toJSON SkConstant = A.Number 14 + toJSON SkString = A.Number 15 + toJSON SkNumber = A.Number 16 + toJSON SkBoolean = A.Number 17 + toJSON SkArray = A.Number 18 + +instance A.FromJSON SymbolKind where + parseJSON (A.Number 1) = pure SkFile + parseJSON (A.Number 2) = pure SkModule + parseJSON (A.Number 3) = pure SkNamespace + parseJSON (A.Number 4) = pure SkPackage + parseJSON (A.Number 5) = pure SkClass + parseJSON (A.Number 6) = pure SkMethod + parseJSON (A.Number 7) = pure SkProperty + parseJSON (A.Number 8) = pure SkField + parseJSON (A.Number 9) = pure SkConstructor + parseJSON (A.Number 10) = pure SkEnum + parseJSON (A.Number 11) = pure SkInterface + parseJSON (A.Number 12) = pure SkFunction + parseJSON (A.Number 13) = pure SkVariable + parseJSON (A.Number 14) = pure SkConstant + parseJSON (A.Number 15) = pure SkString + parseJSON (A.Number 16) = pure SkNumber + parseJSON (A.Number 17) = pure SkBoolean + parseJSON (A.Number 18) = pure SkArray + parseJSON _ = mempty + + +-- --------------------------------------------------------------------- + +data SymbolInformation = + SymbolInformation + { _name :: Text + , _kind :: SymbolKind + , _location :: Location + , _containerName :: Maybe Text -- ^The name of the symbol containing this + -- symbol. + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''SymbolInformation) +makeFieldsNoPrefix ''SymbolInformation + + +-- ------------------------------------- + +type DocumentSymbolRequest = RequestMessage ClientMethod DocumentSymbolParams (List SymbolInformation) +type DocumentSymbolsResponse = ResponseMessage (List SymbolInformation) + +-- --------------------------------------------------------------------- +{- +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. +-} + +data WorkspaceSymbolParams = + WorkspaceSymbolParams + { _query :: Text + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''WorkspaceSymbolParams) +makeFieldsNoPrefix ''WorkspaceSymbolParams + +type WorkspaceSymbolRequest = RequestMessage ClientMethod WorkspaceSymbolParams (List SymbolInformation) +type WorkspaceSymbolsResponse = ResponseMessage (List SymbolInformation) + +-- --------------------------------------------------------------------- +{- +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. The request is triggered when the +user moves the cursor into a problem marker in the editor or presses the +lightbulb associated with a marker. + +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; +} + +/** + * Contains additional diagnostic information about the context in which + * a code action is run. + */ +interface CodeActionContext { + /** + * An array of diagnostics. + */ + diagnostics: Diagnostic[]; +} + +Response + + result: Command[] defined as follows: + error: code and message set in case an exception happens during the code + action request. + +-} + +data CodeActionContext = + CodeActionContext + { _diagnostics :: List Diagnostic + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''CodeActionContext) +makeFieldsNoPrefix ''CodeActionContext + + +data CodeActionParams = + CodeActionParams + { _textDocument :: TextDocumentIdentifier + , _range :: Range + , _context :: CodeActionContext + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''CodeActionParams) +makeFieldsNoPrefix ''CodeActionParams + + +type CodeActionRequest = RequestMessage ClientMethod CodeActionParams (List Command) +type CodeActionResponse = ResponseMessage (List Command) + +-- --------------------------------------------------------------------- +{- +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 + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''CodeLensParams) +makeFieldsNoPrefix ''CodeLensParams + + +-- ------------------------------------- + +data CodeLens = + CodeLens + { _range :: Range + , _command :: Maybe Command + , _xdata :: Maybe A.Value + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens) +makeFieldsNoPrefix ''CodeLens + + +type CodeLensRequest = RequestMessage ClientMethod CodeLensParams (List CodeLens) +type CodeLensResponse = ResponseMessage (List 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) +makeFieldsNoPrefix ''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. + + +-} + +type CodeLensResolveRequest = RequestMessage ClientMethod CodeLens (List CodeLens) +type CodeLensResolveResponse = ResponseMessage (List CodeLens) + +-- --------------------------------------------------------------------- +{- +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 + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''DocumentLinkParams) +makeFieldsNoPrefix ''DocumentLinkParams + +data DocumentLink = + DocumentLink + { _range :: Range + , _target :: Maybe Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''DocumentLink) +makeFieldsNoPrefix ''DocumentLink + +type DocumentLinkRequest = RequestMessage ClientMethod DocumentLinkParams (List DocumentLink) +type DocumentLinkResponse = ResponseMessage (List 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. + +-} + +type DocumentLinkResolveRequest = RequestMessage ClientMethod DocumentLink DocumentLink +type DocumentLinkResolveResponse = ResponseMessage DocumentLink + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''FormattingOptions + +data DocumentFormattingParams = + DocumentFormattingParams + { _textDocument :: TextDocumentIdentifier + , _options :: FormattingOptions + } deriving (Show,Read,Eq) + +$(deriveJSON lspOptions ''DocumentFormattingParams) +makeFieldsNoPrefix ''DocumentFormattingParams + +type DocumentFormattingRequest = RequestMessage ClientMethod DocumentFormattingParams (List TextEdit) +type DocumentFormattingResponse = ResponseMessage (List TextEdit) + +-- --------------------------------------------------------------------- +{- +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 + } deriving (Read,Show,Eq) + +$(deriveJSON lspOptions ''DocumentRangeFormattingParams) +makeFieldsNoPrefix ''DocumentRangeFormattingParams + +type DocumentRangeFormattingRequest = RequestMessage ClientMethod DocumentRangeFormattingParams (List TextEdit) +type DocumentRangeFormattingResponse = ResponseMessage (List TextEdit) + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''DocumentOnTypeFormattingParams + +type DocumentOnTypeFormattingRequest = RequestMessage ClientMethod DocumentOnTypeFormattingParams (List TextEdit) +type DocumentOnTypeFormattingResponse = ResponseMessage (List TextEdit) + +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 + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''RenameParams) +makeFieldsNoPrefix ''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 + +-- --------------------------------------------------------------------- +{- +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[] +} +-} + +data ExecuteCommandParams = + ExecuteCommandParams + { _command :: Text + , _arguments :: Maybe (List A.Value) + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''ExecuteCommandParams) +makeFieldsNoPrefix ''ExecuteCommandParams + +type ExecuteCommandRequest = RequestMessage ClientMethod ExecuteCommandParams A.Value +type ExecuteCommandResponse = ResponseMessage A.Value + +data ExecuteCommandRegistrationOptions = + ExecuteCommandRegistrationOptions + { _commands :: List Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''ExecuteCommandRegistrationOptions) +makeFieldsNoPrefix ''ExecuteCommandRegistrationOptions + +-- --------------------------------------------------------------------- +{- +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) +makeFieldsNoPrefix ''ApplyWorkspaceEditParams + +data ApplyWorkspaceEditResponseBody = + ApplyWorkspaceEditResponseBody + { _applied :: Bool + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''ApplyWorkspaceEditResponseBody) +makeFieldsNoPrefix ''ApplyWorkspaceEditResponseBody + +-- | Sent from the server to the client +type ApplyWorkspaceEditRequest = RequestMessage ServerMethod ApplyWorkspaceEditParams ApplyWorkspaceEditResponseBody +type ApplyWorkspaceEditResponse = ResponseMessage ApplyWorkspaceEditResponseBody + +-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +-- --------------------------------------------------------------------- + +data TraceNotificationParams = + TraceNotificationParams { + _value :: Text + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TraceNotificationParams) +makeFieldsNoPrefix ''TraceNotificationParams + + +data TraceNotification = + TraceNotification { + _params :: TraceNotificationParams + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''TraceNotification) +makeFieldsNoPrefix ''TraceNotification + + + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/LSP/Utility.hs b/src/Language/Haskell/LSP/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Utility.hs @@ -0,0 +1,59 @@ +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 + + +-- | +-- +rdrop :: Int -> [a] -> [a] +rdrop cnt = reverse . drop cnt . reverse + +-- --------------------------------------------------------------------- + +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 new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/VFS.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- + +Manage the J.TextDocumentDidChange messages to keep a local copy of the files +in the client workspace, so that tools at the server can operate on them. +-} +module Language.Haskell.LSP.VFS + ( + VFS + , VirtualFile(..) + , openVFS + , changeVFS + , closeVFS + + -- * for tests + , sortChanges + , deleteChars , addChars + , changeChars + , yiSplitAt + ) where + +import Data.Text ( Text ) +import Data.List +import qualified Data.Map as Map +import qualified Language.Haskell.LSP.TH.DataTypesJSON as J +import Language.Haskell.LSP.Utility +import qualified Yi.Rope as Yi + +-- --------------------------------------------------------------------- +{-# ANN module ("hlint: ignore Eta reduce" :: String) #-} +{-# ANN module ("hlint: ignore Redundant do" :: String) #-} +-- --------------------------------------------------------------------- + +data VirtualFile = + VirtualFile { + _version :: Int + , _text :: Yi.YiString + } deriving (Show) + +type VFS = Map.Map J.Uri VirtualFile + +-- --------------------------------------------------------------------- + +openVFS :: VFS -> J.DidOpenTextDocumentNotification -> IO VFS +openVFS vfs (J.NotificationMessage _ _ params) = do + let J.DidOpenTextDocumentParams + (J.TextDocumentItem uri _ version text) = params + return $ Map.insert uri (VirtualFile version (Yi.fromText text)) vfs + +-- --------------------------------------------------------------------- + +changeVFS :: VFS -> J.DidChangeTextDocumentNotification -> IO VFS +changeVFS vfs (J.NotificationMessage _ _ params) = do + let + J.DidChangeTextDocumentParams vid (J.List changes) = params + J.VersionedTextDocumentIdentifier uri version = vid + case Map.lookup uri vfs of + Just (VirtualFile _ str) -> do + let str' = applyChanges str changes + return $ Map.insert uri (VirtualFile version str') vfs + Nothing -> do + logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri + return vfs + +-- --------------------------------------------------------------------- + +closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> IO VFS +closeVFS vfs (J.NotificationMessage _ _ params) = do + let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params + return $ Map.delete uri vfs + +-- --------------------------------------------------------------------- +{- + +data TextDocumentContentChangeEvent = + TextDocumentContentChangeEvent + { _range :: Maybe Range + , _rangeLength :: Maybe Int + , _text :: String + } deriving (Read,Show,Eq) +-} + +-- | Apply the list of changes, in descending order of range. Assuming no overlaps. +applyChanges :: Yi.YiString -> [J.TextDocumentContentChangeEvent] -> Yi.YiString +applyChanges str changes' = r + where + changes = sortChanges changes' + r = foldl' applyChange str changes + +-- --------------------------------------------------------------------- + +applyChange :: Yi.YiString -> J.TextDocumentContentChangeEvent -> Yi.YiString +applyChange _ (J.TextDocumentContentChangeEvent Nothing Nothing str) + = Yi.fromText str +applyChange str (J.TextDocumentContentChangeEvent (Just (J.Range fm _to)) (Just len) txt) = + if txt == "" + then -- delete len chars from fm + deleteChars str fm len + else -- add or change, based on length + if len == 0 + then addChars str fm txt + -- Note: changChars comes from applyEdit, emacs will split it into a + -- delete and an add + else changeChars str fm len txt +applyChange str (J.TextDocumentContentChangeEvent (Just (J.Range _fm _to)) Nothing _txt) + -- TODO: This case may occur in the wild, need to convert to-fm into a length. + -- Or encode a specific addChar function + = str +applyChange str (J.TextDocumentContentChangeEvent Nothing (Just _) _txt) + = str + +-- --------------------------------------------------------------------- + +deleteChars :: Yi.YiString -> J.Position -> Int -> Yi.YiString +deleteChars str (J.Position l c) len = str' + where + (before,after) = Yi.splitAtLine l str + -- after contains the area we care about, starting with the selected line. + -- Due to LSP zero-based coordinates + beforeOnLine = Yi.take c after + after' = Yi.drop (c + len) after + str' = Yi.append before (Yi.append beforeOnLine after') + +-- --------------------------------------------------------------------- + +addChars :: Yi.YiString -> J.Position -> Text -> Yi.YiString +addChars str (J.Position l c) new = str' + where + (before,after) = Yi.splitAtLine l str + -- after contains the area we care about, starting with the selected line. + -- Due to LSP zero-based coordinates + beforeOnLine = Yi.take c after + after' = Yi.drop c after + str' = Yi.concat [before, beforeOnLine, (Yi.fromText new), after'] + +-- --------------------------------------------------------------------- + +changeChars :: Yi.YiString -> J.Position -> Int -> Text -> Yi.YiString +changeChars str (J.Position ls cs) len new = str' + where + (before,after) = yiSplitAt ls cs str + after' = Yi.drop len after + + str' = Yi.concat [before, (Yi.fromText new), after'] + +-- changeChars :: Yi.YiString -> J.Position -> J.Position -> String -> Yi.YiString +-- changeChars str (J.Position ls cs) (J.Position le ce) new = str' +-- where +-- (before,_after) = yiSplitAt ls cs str +-- (_before,after) = yiSplitAt le ce str + +-- str' = Yi.concat [before, (Yi.fromString new), after] +-- -- str' = Yi.concat [before] +-- -- str' = Yi.concat [_before] + +-- --------------------------------------------------------------------- + +yiSplitAt :: Int -> Int -> Yi.YiString -> (Yi.YiString, Yi.YiString) +yiSplitAt l c str = (before,after) + where + (b,a) = Yi.splitAtLine l str + before = Yi.concat [b,Yi.take c a] + after = Yi.drop c a + + +-- --------------------------------------------------------------------- + +sortChanges :: [J.TextDocumentContentChangeEvent] -> [J.TextDocumentContentChangeEvent] +sortChanges changes = changes' + where + myComp (J.TextDocumentContentChangeEvent (Just r1) _ _) + (J.TextDocumentContentChangeEvent (Just r2) _ _) + = compare r2 r1 -- want descending order + myComp _ _ = EQ + changes' = sortBy myComp changes + +-- --------------------------------------------------------------------- diff --git a/test/DiagnosticsSpec.hs b/test/DiagnosticsSpec.hs new file mode 100644 --- /dev/null +++ b/test/DiagnosticsSpec.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedStrings #-} +module DiagnosticsSpec where + + +import qualified Data.Map as Map +-- import qualified Data.Text as T +import Data.Text ( Text ) +import Language.Haskell.LSP.Diagnostics +import qualified Language.Haskell.LSP.TH.DataTypesJSON as J + +import Test.Hspec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Diagnostics functions" diagnosticsSpec + +-- -- |Used when running from ghci, and it sets the current directory to ./tests +-- tt :: IO () +-- tt = do +-- cd ".." +-- hspec spec + +-- --------------------------------------------------------------------- + +mkDiagnostic :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic ms str = J.Diagnostic (J.Range (J.Position 0 1) (J.Position 3 0)) Nothing Nothing ms str + +-- --------------------------------------------------------------------- + +diagnosticsSpec :: Spec +diagnosticsSpec = do + describe "constructs a new store" $ do + it "constructs a store with no doc version and a single source" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "hlint") "b" + ] + (updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags)) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList [(Just "hlint", reverse diags) ] ) + ] + + -- --------------------------------- + + it "constructs a store with no doc version and multiple sources" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "ghcmod") "b" + ] + (updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags)) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList + [(Just "hlint", [mkDiagnostic (Just "hlint") "a"]) + ,(Just "ghcmod", [mkDiagnostic (Just "ghcmod") "b"]) + ]) + ] + + -- --------------------------------- + + it "constructs a store with doc version and multiple sources" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "ghcmod") "b" + ] + (updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags)) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem (Just 1) $ Map.fromList + [(Just "hlint", [mkDiagnostic (Just "hlint") "a"]) + ,(Just "ghcmod", [mkDiagnostic (Just "ghcmod") "b"]) + ]) + ] + + -- --------------------------------- + + describe "updates a store for same document version" $ do + it "updates a store without a document version, single source only" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "hlint") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + let origStore = updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags1) + (updateDiagnostics origStore (J.Uri "uri") Nothing (partitionBySource diags2)) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList [(Just "hlint", diags2) ] ) + ] + + -- --------------------------------- + + it "updates just one source of a 2 source store" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "ghcmod") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + let origStore = updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags1) + (updateDiagnostics origStore (J.Uri "uri") Nothing (partitionBySource diags2)) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList + [(Just "hlint", [mkDiagnostic (Just "hlint") "a2"]) + ,(Just "ghcmod", [mkDiagnostic (Just "ghcmod") "b1"]) + ] ) + ] + + -- --------------------------------- + + it "updates just one source of a 2 source store, with empty diags" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "ghcmod") "b1" + ] + let origStore = updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags1) + (updateDiagnostics origStore (J.Uri "uri") Nothing (Map.fromList [(Just "ghcmod", [])])) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList + [(Just "ghcmod", []) + ,(Just "hlint", [mkDiagnostic (Just "hlint") "a1"]) + ] ) + ] + + + -- --------------------------------- + + describe "updates a store for a new document version" $ do + it "updates a store without a document version, single source only" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "hlint") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + let origStore = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags1) + (updateDiagnostics origStore (J.Uri "uri") (Just 2) (partitionBySource diags2)) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem (Just 2) $ Map.fromList [(Just "hlint", diags2) ] ) + ] + + -- --------------------------------- + + it "updates a store for a new doc version, removing all priot sources" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "ghcmod") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + let origStore = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags1) + (updateDiagnostics origStore (J.Uri "uri") (Just 2) (partitionBySource diags2)) `shouldBe` + Map.fromList + [ ((J.Uri "uri"),StoreItem (Just 2) $ Map.fromList + [(Just "hlint", [mkDiagnostic (Just "hlint") "a2"]) + ] ) + ] + + -- --------------------------------- + + describe "retrieves all the diagnostics for a given uri" $ do + + it "gets diagnostics for multiple sources" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "ghcmod") "b" + ] + let ds = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags) + (getDiagnosticParamsFor ds (J.Uri "uri")) `shouldBe` + Just (J.PublishDiagnosticsParams (J.Uri "uri") (J.List $ reverse diags)) + + -- --------------------------------- diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,22 @@ +module Main where + + +-- import Test.Hspec.Formatters.Jenkins +import Test.Hspec.Runner +import qualified Spec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec Spec.spec + +-- main :: IO () +-- main = do +-- summary <- withFile "results.xml" WriteMode $ \h -> do +-- let c = defaultConfig +-- { configFormatter = xmlFormatter +-- , configHandle = h +-- } +-- hspecWith c Spec.spec +-- unless (summaryFailures summary == 0) $ +-- exitFailure diff --git a/test/MethodSpec.hs b/test/MethodSpec.hs new file mode 100644 --- /dev/null +++ b/test/MethodSpec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +module MethodSpec where + + +import Control.Monad +import qualified Data.Aeson as J +import qualified Language.Haskell.LSP.TH.DataTypesJSON as J +import Test.Hspec +import qualified Data.Text as T + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Method enum aeson instance consistency" diagnosticsSpec + +-- --------------------------------------------------------------------- + +clientMethods :: [T.Text] +clientMethods = [ + -- General + "initialize" + ,"initialized" + ,"shutdown" + ,"exit" + ,"$/cancelRequest" + -- Workspace + ,"workspace/didChangeConfiguration" + ,"workspace/didChangeWatchedFiles" + ,"workspace/symbol" + ,"workspace/executeCommand" + -- Document + ,"textDocument/didOpen" + ,"textDocument/didChange" + ,"textDocument/willSave" + ,"textDocument/willSaveWaitUntil" + ,"textDocument/didSave" + ,"textDocument/didClose" + ,"textDocument/completion" + ,"completionItem/resolve" + ,"textDocument/hover" + ,"textDocument/signatureHelp" + ,"textDocument/references" + ,"textDocument/documentHighlight" + ,"textDocument/documentSymbol" + ,"textDocument/formatting" + ,"textDocument/rangeFormatting" + ,"textDocument/onTypeFormatting" + ,"textDocument/definition" + ,"textDocument/codeAction" + ,"textDocument/codeLens" + ,"codeLens/resolve" + ,"textDocument/documentLink" + ,"documentLink/resolve" + ,"textDocument/rename" + ] + +serverMethods :: [T.Text] +serverMethods = [ + -- Window + "window/showMessage" + ,"window/showMessageRequest" + ,"window/logMessage" + ,"telemetry/event" + -- Client + ,"client/registerCapability" + ,"client/unregisterCapability" + -- Workspace + ,"workspace/applyEdit" + -- Document + ,"textDocument/publishDiagnostics" + ] + +diagnosticsSpec :: Spec +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)) + `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)) + `shouldBe` (J.Success $ J.String m) + + -- --------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} +{- + +See https://github.com/hspec/hspec/tree/master/hspec-discover#readme +to understand this module + +Or http://hspec.github.io/hspec-discover.html + +-} diff --git a/test/VspSpec.hs b/test/VspSpec.hs new file mode 100644 --- /dev/null +++ b/test/VspSpec.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE OverloadedStrings #-} +module VspSpec where + + +import Language.Haskell.LSP.VFS +import qualified Language.Haskell.LSP.TH.DataTypesJSON as J +import qualified Yi.Rope as Yi + +import Test.Hspec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "VSP functions" vspSpec + +-- -- |Used when running from ghci, and it sets the current directory to ./tests +-- tt :: IO () +-- tt = do +-- cd ".." +-- hspec spec + +-- --------------------------------------------------------------------- + + +mkRange :: Int -> Int -> Int -> Int -> Maybe J.Range +mkRange ls cs le ce = Just $ J.Range (J.Position ls cs) (J.Position le ce) + +-- --------------------------------------------------------------------- + +vspSpec :: Spec +vspSpec = do + describe "sorts changes" $ do + it "sorts changes that all have ranges" $ do + let + unsorted = + [ (J.TextDocumentContentChangeEvent (mkRange 1 0 2 0) Nothing "") + , (J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "") + ] + (sortChanges unsorted) `shouldBe` + [ (J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "") + , (J.TextDocumentContentChangeEvent (mkRange 1 0 2 0) Nothing "") + ] + + -- --------------------------------- + + describe "deletes characters" $ do + it "deletes characters within a line" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = deleteChars (Yi.fromString orig) (J.Position 2 1) 4 + lines (Yi.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "-oo" + , "foo :: Int" + ] + + -- --------------------------------- + + it "deletes one line" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = deleteChars (Yi.fromString orig) (J.Position 2 0) 8 + lines (Yi.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] + -- --------------------------------- + + it "deletes two lines" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + new = deleteChars (Yi.fromString orig) (J.Position 1 0) 19 + lines (Yi.toString new) `shouldBe` + [ "module Foo where" + , "foo = bb" + ] + + -- --------------------------------- + + describe "adds characters" $ do + it "adds one line" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] + new = addChars (Yi.fromString orig) (J.Position 1 16) "\n-- fooo" + lines (Yi.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + + -- --------------------------------- + + it "adds two lines" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "foo = bb" + ] + new = addChars (Yi.fromString orig) (J.Position 1 8) "\n-- fooo\nfoo :: Int" + lines (Yi.toString new) `shouldBe` + [ "module Foo where" + , "foo = bb" + , "-- fooo" + , "foo :: Int" + ] + + -- --------------------------------- + + describe "changes characters" $ do + it "removes end of a line" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + -- new = changeChars (Yi.fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" + new = changeChars (Yi.fromString orig) (J.Position 7 0) 8 "baz =" + lines (Yi.toString new) `shouldBe` + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz =" + , " putStrLn \"hello world\"" + ]