diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,5 +2,9 @@ ## 0.1.0.0 -- 2017-07-19 +* Major changes as implementation continued. Now seems stable, used in haskell-ide-engine + +## 0.1.0.0 -- 2017-07-19 + * First version. Implements version 3 of the Microsoft Language Server Protocol diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,6 @@ +[![CircleCI](https://img.shields.io/circleci/project/github/alanz/haskell-lsp.svg)](https://circleci.com/gh/alanz/haskell-lsp) +[![Hackage](https://img.shields.io/hackage/v/haskell-lsp.svg)](https://hackage.haskell.org/package/haskell-lsp) + # haskell-lsp Haskell library for the Microsoft Language Server Protocol @@ -8,7 +11,7 @@ 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 + git clone https://github.com/haskell/haskell-ide-engine cd haskell-ide-engine stack install diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -12,7 +12,6 @@ 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 @@ -56,15 +55,15 @@ let dp lf = do liftIO $ U.logs $ "main.run:dp entered" - _rpid <- forkIO $ reactor lf def rin + _rpid <- forkIO $ reactor lf 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 + Core.setupLogger (Just "/tmp/lsp-hello.log") [] L.DEBUG + CTRL.run (return (Right ()), dp) (lspHandlers rin) lspOptions where handlers = [ E.Handler ioExcept @@ -84,18 +83,10 @@ = 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 +type R c a = ReaderT (Core.LspFuncs c) IO a -- --------------------------------------------------------------------- -- reactor monad functions @@ -103,36 +94,34 @@ -- --------------------------------------------------------------------- -reactorSend :: (J.ToJSON a) => a -> R () +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 +publishDiagnostics :: Int -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> R () () +publishDiagnostics maxToPublish uri mv diags = do lf <- ask - liftIO $ (Core.publishDiagnosticsFunc lf) uri mv diags + liftIO $ (Core.publishDiagnosticsFunc lf) maxToPublish uri mv diags -- --------------------------------------------------------------------- -nextLspReqId :: R J.LspId +nextLspReqId :: R () J.LspId nextLspReqId = do - s <- get - let i@(J.IdInt r) = lspReqId s - put s { lspReqId = J.IdInt (r + 1) } - return i + f <- asks Core.getNextReqId + liftIO $ f -- --------------------------------------------------------------------- -- | The single point that all events flow through, allowing management of state -- to stitch replies and requests together from the two asynchronous sides: lsp -- server and backend compiler -reactor :: Core.LspFuncs -> ReactorState -> TChan ReactorInput -> IO () -reactor lf st inp = do +reactor :: Core.LspFuncs () -> TChan ReactorInput -> IO () +reactor lf inp = do liftIO $ U.logs $ "reactor:entered" - flip evalStateT st $ flip runReaderT lf $ forever $ do + flip runReaderT lf $ forever $ do inval <- liftIO $ atomically $ readTChan inp case inval of @@ -315,7 +304,7 @@ -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification -sendDiagnostics :: J.Uri -> Maybe Int -> R () +sendDiagnostics :: J.Uri -> Maybe Int -> R () () sendDiagnostics fileUri mversion = do let diags = [J.Diagnostic @@ -326,15 +315,21 @@ "Example diagnostic message" ] -- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r) - publishDiagnostics fileUri mversion (partitionBySource diags) + publishDiagnostics 100 fileUri mversion (partitionBySource diags) -- --------------------------------------------------------------------- -syncMethod :: J.TextDocumentSyncKind -syncMethod = J.TdSyncIncremental +syncOptions :: J.TextDocumentSyncOptions +syncOptions = J.TextDocumentSyncOptions + { J._openClose = Just True + , J._change = Just J.TdSyncIncremental + , J._willSave = Just False + , J._willSaveWaitUntil = Just False + , J._save = Just $ J.SaveOptions $ Just False + } lspOptions :: Core.Options -lspOptions = def { Core.textDocumentSync = Just syncMethod +lspOptions = def { Core.textDocumentSync = Just syncOptions , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["lsp-hello-command"])) } diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -1,5 +1,5 @@ name: haskell-lsp -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -14,7 +14,7 @@ license-file: LICENSE author: Alan Zimmerman maintainer: alan.zimm@gmail.com -copyright: Alan Zimmerman, 2016 +copyright: Alan Zimmerman, 2016-2017 category: Development build-type: Simple extra-source-files: ChangeLog.md, README.md @@ -35,7 +35,7 @@ -- other-extensions: ghc-options: -Wall -- ghc-options: -Werror - build-depends: base >=4.9 && <4.10 + build-depends: base >=4.9 && <4.11 , aeson >=1.0.0.0 , bytestring , containers @@ -47,6 +47,7 @@ , lens >= 4.15.2 , mtl , parsec + , sorted-list == 0.2.0.* , stm , text , time @@ -62,7 +63,7 @@ default-language: Haskell2010 ghc-options: -Wall - build-depends: base >=4.9 && <4.10 + build-depends: base >=4.9 && <4.11 , aeson , bytestring , containers @@ -100,6 +101,7 @@ , hashable -- , hspec-jenkins , lens >= 4.15.2 + , sorted-list == 0.2.0.* , yi-rope , haskell-lsp -- , data-default diff --git a/src/Language/Haskell/LSP/Constant.hs b/src/Language/Haskell/LSP/Constant.hs --- a/src/Language/Haskell/LSP/Constant.hs +++ b/src/Language/Haskell/LSP/Constant.hs @@ -8,5 +8,6 @@ _LOG_FORMAT = "$time [$tid] - $msg" _LOG_FORMAT_DATE :: String -_LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S" +-- _LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S" +_LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S%Q" diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -12,6 +12,7 @@ import Control.Concurrent import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TVar import Control.Monad import Control.Monad.STM import qualified Data.Aeson as J @@ -25,9 +26,10 @@ -- --------------------------------------------------------------------- -run :: Core.InitializeCallback -- ^ function to be called once initialize has - -- been received from the client. Further message - -- processing will start only after this returns. +run :: (Show c) => Core.InitializeCallback c + -- ^ 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 @@ -46,20 +48,20 @@ let sendFunc :: Core.SendFunc sendFunc str = atomically $ writeTChan cout (J.encode str) - let lf = error "LifeCycle error, ClientCapabilites not set yet via initialize maessage" + let lf = error "LifeCycle error, ClientCapabilities not set yet via initialize maessage" - mvarDat <- newMVar ((Core.defaultLanguageContextData h o lf :: Core.LanguageContextData) - { Core.resSendResponse = sendFunc - } ) + tvarId <- atomically $ newTVar 0 - ioLoop dp mvarDat + tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc + ioLoop dp tvarDat + return 1 -- --------------------------------------------------------------------- -ioLoop :: Core.InitializeCallback -> MVar Core.LanguageContextData -> IO () -ioLoop dispatcherProc mvarDat = go BSL.empty +ioLoop :: (Show c) => Core.InitializeCallback c -> TVar (Core.LanguageContextData c) -> IO () +ioLoop dispatcherProc tvarDat = go BSL.empty where go :: BSL.ByteString -> IO () go buf = do @@ -81,8 +83,8 @@ return () else do logm $ (B.pack "---> ") <> cnt - Core.handleRequest dispatcherProc mvarDat newBuf cnt - ioLoop dispatcherProc mvarDat + Core.handleRequest dispatcherProc tvarDat newBuf cnt + ioLoop dispatcherProc tvarDat where readContentLength :: String -> Either ParseError Int readContentLength = parse parser "readContentLength" diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -24,9 +24,10 @@ , sendErrorResponseS , sendErrorLogS , sendErrorShowS + , reverseSortEdit ) where -import Control.Concurrent +import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad import Control.Lens ( (<&>), (^.) ) @@ -66,7 +67,7 @@ type SendFunc = forall a. (J.ToJSON a => a -> IO ()) -- | state used by the LSP dispatcher to manage the message loop -data LanguageContextData = +data LanguageContextData a = LanguageContextData { resSeqDebugContextData :: !Int , resRootPath :: !(Maybe FilePath) @@ -75,7 +76,9 @@ , resSendResponse :: !SendFunc , resVFS :: !VFS , resDiagnostics :: !DiagnosticStore - , resLspFuncs :: LspFuncs -- NOTE: Cannot be strict, lazy initialization + , resConfig :: !(Maybe a) + , resLspId :: !(TVar Int) + , resLspFuncs :: LspFuncs a -- NOTE: Cannot be strict, lazy initialization } -- --------------------------------------------------------------------- @@ -85,7 +88,7 @@ -- during initialization. data Options = Options - { textDocumentSync :: Maybe J.TextDocumentSyncKind + { textDocumentSync :: Maybe J.TextDocumentSyncOptions , completionProvider :: Maybe J.CompletionOptions , signatureHelpProvider :: Maybe J.SignatureHelpOptions , codeLensProvider :: Maybe J.CodeLensOptions @@ -99,23 +102,34 @@ -- | 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 () +-- 'textDocument/publishDiagnostics' notification with the total (limited by the +-- first parameter) whenever it is updated. +type PublishDiagnosticsFunc = Int -- Max number of diagnostics to send + -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> IO () +-- | A function to remove all diagnostics from a particular source, and send the updates to the client. +type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send + -> Maybe J.DiagnosticSource -> IO () + -- | Returned to the server on startup, providing ways to interact with the client. -data LspFuncs = +data LspFuncs c = LspFuncs - { clientCapabilities :: !C.ClientCapabilities - , sendFunc :: !SendFunc - , getVirtualFileFunc :: !(J.Uri -> IO (Maybe VirtualFile)) - , publishDiagnosticsFunc :: !PublishDiagnosticsFunc + { clientCapabilities :: !C.ClientCapabilities + , config :: !(IO (Maybe c)) + -- ^ Derived from the DidChangeConfigurationNotification message via a + -- server-provided function. + , sendFunc :: !SendFunc + , getVirtualFileFunc :: !(J.Uri -> IO (Maybe VirtualFile)) + , publishDiagnosticsFunc :: !PublishDiagnosticsFunc + , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc + , getNextReqId :: !(IO J.LspId) } -- | 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) +type InitializeCallback c = ( J.DidChangeConfigurationNotification-> Either T.Text c + , LspFuncs c -> 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 @@ -179,17 +193,24 @@ nop = const . return helper :: J.FromJSON a - => (MVar LanguageContextData -> a -> IO ()) - -> (MVar LanguageContextData -> J.Value -> IO ()) -helper requestHandler mvarDat json = + => (TVar (LanguageContextData c) -> a -> IO ()) + -> (TVar (LanguageContextData c) -> J.Value -> IO ()) +helper requestHandler tvarDat json = case J.fromJSON json of - J.Success req -> requestHandler mvarDat req + J.Success req -> requestHandler tvarDat req J.Error err -> do let msg = T.pack . unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL - sendErrorLog mvarDat msg + failLog = sendErrorLog tvarDat msg + case json of + (J.Object o) -> case HM.lookup "id" o of + Just olid -> case J.fromJSON olid of + J.Success lid -> sendErrorResponse tvarDat lid msg + _ -> failLog + _ -> failLog + _ -> failLog -handlerMap :: InitializeCallback - -> Handlers -> J.ClientMethod -> (MVar LanguageContextData -> J.Value -> IO ()) +handlerMap :: (Show c) => InitializeCallback c + -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData c) -> J.Value -> IO ()) -- General handlerMap i _ J.Initialize = helper (initializeRequestHandler i) handlerMap _ h J.Initialized = hh nop $ initializedHandler h @@ -199,7 +220,7 @@ exitSuccess handlerMap _ h J.CancelRequest = hh nop $ cancelNotificationHandler h -- Workspace -handlerMap _ h J.WorkspaceDidChangeConfiguration = hh nop $ didChangeConfigurationParamsHandler h +handlerMap i h J.WorkspaceDidChangeConfiguration = hc i $ 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 @@ -228,41 +249,73 @@ 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 + where f :: TVar (LanguageContextData c) -> J.TraceNotification -> IO () + f tvarDat _ = do let msg = "haskell-lsp:Got " ++ T.unpack x ++ " ignoring" logm (B.pack msg) - sendErrorLog mvarDat (T.pack msg) + sendErrorLog tvarDat (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 +hh :: forall b c. (J.FromJSON b) + => (VFS -> b -> IO VFS) -> Maybe (Handler b) -> TVar (LanguageContextData c) -> J.Value -> IO () +hh getVfs mh tvarDat json = do case J.fromJSON json of J.Success req -> do - ctx <- readMVar mvarDat + ctx <- readTVarIO tvarDat vfs' <- getVfs (resVFS ctx) req - modifyMVar_ mvarDat (\c -> return c {resVFS = vfs'}) - h req + atomically $ modifyTVar' tvarDat (\c -> c {resVFS = vfs'}) + case mh of + Just h -> h req + Nothing -> do + let msg = T.pack $ unwords ["haskell-lsp:no handler for.", show json] + sendErrorLog tvarDat msg J.Error err -> do let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL - sendErrorLog mvarDat msg + sendErrorLog tvarDat msg +hc :: (Show c) => InitializeCallback c -> Maybe (Handler J.DidChangeConfigurationNotification) + -> TVar (LanguageContextData c) -> J.Value -> IO () +hc (c,_) mh tvarDat json = do + -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification entered" + case J.fromJSON json of + J.Success req -> do + ctx <- readTVarIO tvarDat + case c req of + Left err -> do + let msg = T.pack $ unwords $ ["haskell-lsp:didChangeConfiguration error.", show req, show err] + sendErrorLog tvarDat msg + Right newConfig -> do + -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification got newConfig:" ++ show newConfig + let ctx' = ctx { resConfig = Just newConfig } + atomically $ modifyTVar' tvarDat (\_ -> ctx') + case mh of + Just h -> h req + Nothing -> return () + J.Error err -> do + let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL + sendErrorLog tvarDat msg + + -- --------------------------------------------------------------------- -getVirtualFile :: MVar LanguageContextData -> J.Uri -> IO (Maybe VirtualFile) -getVirtualFile mvarDat uri = do - ctx <- readMVar mvarDat +getVirtualFile :: TVar (LanguageContextData c) -> J.Uri -> IO (Maybe VirtualFile) +getVirtualFile tvarDat uri = do + ctx <- readTVarIO tvarDat return $ Map.lookup uri (resVFS ctx) -- --------------------------------------------------------------------- +getConfig :: TVar (LanguageContextData c) -> IO (Maybe c) +getConfig tvar = do + ctx <- readTVarIO tvar + return (resConfig 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 @@ -307,6 +360,7 @@ | NotDidOpenTextDocument J.DidOpenTextDocumentNotification | NotDidChangeTextDocument J.DidChangeTextDocumentNotification | NotDidCloseTextDocument J.DidCloseTextDocumentNotification + | NotWillSaveTextDocument J.WillSaveTextDocumentNotification | NotDidSaveTextDocument J.DidSaveTextDocumentNotification | NotDidChangeWatchedFiles J.DidChangeWatchedFilesNotification @@ -347,14 +401,15 @@ -- | -- -- -defaultLanguageContextData :: Handlers -> Options -> LspFuncs -> LanguageContextData -defaultLanguageContextData h o lf = LanguageContextData _INITIAL_RESPONSE_SEQUENCE Nothing h o (BSL.putStr . J.encode) mempty mempty lf +defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> LanguageContextData c +defaultLanguageContextData h o lf tv sf = + LanguageContextData _INITIAL_RESPONSE_SEQUENCE Nothing h o sf mempty mempty Nothing tv lf -- --------------------------------------------------------------------- -handleRequest :: InitializeCallback - -> MVar LanguageContextData -> BSL.ByteString -> BSL.ByteString -> IO () -handleRequest dispatcherProc mvarDat contLenStr jsonStr = do +handleRequest :: (Show c) => InitializeCallback c + -> TVar (LanguageContextData c) -> BSL.ByteString -> BSL.ByteString -> IO () +handleRequest dispatcherProc tvarDat contLenStr jsonStr = do {- Message Types we must handle are the following @@ -369,15 +424,16 @@ 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 + sendErrorLog tvarDat msg Right o -> do case HM.lookup "method" o of Just cmd@(J.String s) -> case J.fromJSON cmd of J.Success m -> handle (J.Object o) m J.Error _ -> do - let msg = T.pack $ unwords ["haskell-lsp:unknown message received:method='" ++ T.unpack s ++ "',", lbs2str contLenStr, lbs2str jsonStr] - sendErrorLog mvarDat msg + let msg = T.pack $ unwords ["haskell-lsp:unknown message received:method='" + ++ T.unpack s ++ "',", lbs2str contLenStr, lbs2str jsonStr] + sendErrorLog tvarDat msg Just oops -> logs $ "haskell-lsp:got strange method param, ignoring:" ++ show oops Nothing -> do logs $ "haskell-lsp:Got reply message:" ++ show jsonStr @@ -385,18 +441,18 @@ where handleResponse json = do - ctx <- readMVar mvarDat + ctx <- readTVarIO tvarDat case responseHandler $ resHandlers ctx of - Nothing -> sendErrorLog mvarDat $ T.pack $ "haskell-lsp: responseHandler is not defined, ignoring response " ++ lbs2str jsonStr + Nothing -> sendErrorLog tvarDat $ T.pack $ "haskell-lsp: responseHandler is not defined, ignoring response " ++ lbs2str jsonStr Just h -> case J.fromJSON json of J.Success res -> h res J.Error err -> let msg = T.pack $ unwords $ ["haskell-lsp:response parse error.", lbs2str jsonStr, show err] ++ _ERR_MSG_URL - in sendErrorLog mvarDat msg + in sendErrorLog tvarDat msg -- capability based handlers handle json cmd = do - ctx <- readMVar mvarDat + ctx <- readTVarIO tvarDat let h = resHandlers ctx - handlerMap dispatcherProc h cmd mvarDat json + handlerMap dispatcherProc h cmd tvarDat json -- --------------------------------------------------------------------- @@ -409,14 +465,14 @@ -- --------------------------------------------------------------------- -- | -- -sendEvent :: J.ToJSON a => MVar LanguageContextData -> a -> IO () -sendEvent mvarCtx str = sendResponse mvarCtx str +sendEvent :: J.ToJSON a => TVar (LanguageContextData c) -> a -> IO () +sendEvent tvarCtx str = sendResponse tvarCtx str -- | -- -sendResponse :: J.ToJSON a => MVar LanguageContextData -> a -> IO () -sendResponse mvarCtx str = do - ctx <- readMVar mvarCtx +sendResponse :: J.ToJSON a => TVar (LanguageContextData c) -> a -> IO () +sendResponse tvarCtx str = do + ctx <- readTVarIO tvarCtx resSendResponse ctx str @@ -424,16 +480,16 @@ -- | -- -- -sendErrorResponse :: MVar LanguageContextData -> J.LspIdRsp -> Text -> IO () -sendErrorResponse mv origId msg = sendErrorResponseS (sendEvent mv) origId J.InternalError msg +sendErrorResponse :: TVar (LanguageContextData c) -> J.LspIdRsp -> Text -> IO () +sendErrorResponse tv origId msg = sendErrorResponseS (sendEvent tv) origId J.InternalError msg sendErrorResponseS :: SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO () sendErrorResponseS sf origId err msg = do sf $ (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 +sendErrorLog :: TVar (LanguageContextData c) -> Text -> IO () +sendErrorLog tv msg = sendErrorLogS (sendEvent tv) msg sendErrorLogS :: SendFunc -> Text -> IO () sendErrorLogS sf msg = @@ -448,13 +504,13 @@ -- --------------------------------------------------------------------- -defaultErrorHandlers :: (Show a) => MVar LanguageContextData -> J.LspIdRsp -> a -> [E.Handler ()] -defaultErrorHandlers mvarDat origId req = [ E.Handler someExcept ] +defaultErrorHandlers :: (Show a) => TVar (LanguageContextData c) -> J.LspIdRsp -> a -> [E.Handler ()] +defaultErrorHandlers tvarDat 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 + sendErrorResponse tvarDat origId msg + sendErrorLog tvarDat msg -- |===================================================================== @@ -463,18 +519,18 @@ -- | -- -initializeRequestHandler :: InitializeCallback - -> MVar LanguageContextData +initializeRequestHandler :: (Show c) => InitializeCallback c + -> TVar (LanguageContextData c) -> J.InitializeRequest -> IO () -initializeRequestHandler dispatcherProc mvarCtx req@(J.RequestMessage _ origId _ params) = - flip E.catches (defaultErrorHandlers mvarCtx (J.responseId origId) req) $ do +initializeRequestHandler (_configHandler,dispatcherProc) tvarCtx req@(J.RequestMessage _ origId _ params) = + flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do - ctx0 <- readMVar mvarCtx + ctx0 <- readTVarIO tvarCtx let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= J.uriToFilePath , params ^. J.rootPath <&> T.unpack ] - modifyMVar_ mvarCtx (\c -> return c { resRootPath = rootDir }) + atomically $ modifyTVar' tvarCtx (\c -> c { resRootPath = rootDir }) case rootDir of Nothing -> return () Just dir -> do @@ -484,20 +540,27 @@ let getCapabilities :: J.InitializeParams -> C.ClientCapabilities getCapabilities (J.InitializeParams _ _ _ _ c _) = c + getLspId tvId = atomically $ do + cid <- readTVar tvId + modifyTVar' tvId (+1) + return $ J.IdInt cid -- Launch the given process once the project root directory has been set let lspFuncs = LspFuncs (getCapabilities params) + (getConfig tvarCtx) (resSendResponse ctx0) - (getVirtualFile mvarCtx) - (publishDiagnostics mvarCtx) + (getVirtualFile tvarCtx) + (publishDiagnostics tvarCtx) + (flushDiagnosticsBySource tvarCtx) + (getLspId $ resLspId ctx0) let ctx = ctx0 { resLspFuncs = lspFuncs } - modifyMVar_ mvarCtx (\_ -> return ctx) + atomically $ writeTVar tvarCtx ctx initializationResult <- dispatcherProc lspFuncs case initializationResult of Just errResp -> do - sendResponse mvarCtx $ makeResponseError (J.responseId origId) errResp + sendResponse tvarCtx $ makeResponseError (J.responseId origId) errResp Nothing -> do @@ -535,32 +598,53 @@ -- 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 + sendResponse tvarCtx res -- | -- -shutdownRequestHandler :: MVar LanguageContextData -> J.ShutdownRequest -> IO () -shutdownRequestHandler mvarCtx req@(J.RequestMessage _ origId _ _) = - flip E.catches (defaultErrorHandlers mvarCtx (J.responseId origId) req) $ do +shutdownRequestHandler :: TVar (LanguageContextData c) -> J.ShutdownRequest -> IO () +shutdownRequestHandler tvarCtx req@(J.RequestMessage _ origId _ _) = + flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do let res = makeResponseMessage req "ok" - sendResponse mvarCtx res + sendResponse tvarCtx 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 +publishDiagnostics :: TVar (LanguageContextData c) -> PublishDiagnosticsFunc +publishDiagnostics tvarDat maxDiagnosticCount uri mversion diags = do + ctx <- readTVarIO tvarDat let ds = updateDiagnostics (resDiagnostics ctx) uri mversion diags - modifyMVar_ mvarDat (\c -> return c {resDiagnostics = ds}) - let mdp = getDiagnosticParamsFor ds uri + atomically $ writeTVar tvarDat $ ctx{resDiagnostics = ds} + let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri case mdp of Nothing -> return () Just params -> do - (resSendResponse ctx) $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params) + resSendResponse ctx + $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params) +-- --------------------------------------------------------------------- + +-- | Take the new diagnostics, update the stored diagnostics for the given file +-- and version, and publish the total to the client. +flushDiagnosticsBySource :: TVar (LanguageContextData c) -> FlushDiagnosticsBySourceFunc +flushDiagnosticsBySource tvarDat maxDiagnosticCount msource = do + -- logs $ "haskell-lsp:flushDiagnosticsBySource:source=" ++ show source + ctx <- readTVarIO tvarDat + let ds = flushBySource (resDiagnostics ctx) msource + atomically $ writeTVar tvarDat $ ctx {resDiagnostics = ds} + -- Send the updated diagnostics to the client + forM_ (Map.keys ds) $ \uri -> do + -- logs $ "haskell-lsp:flushDiagnosticsBySource:uri=" ++ show uri + let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri + case mdp of + Nothing -> return () + Just params -> do + resSendResponse ctx + $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params) + -- |===================================================================== -- -- utility @@ -569,10 +653,12 @@ -- | -- Logger -- -setupLogger :: FilePath -> [String] -> Priority -> IO () -setupLogger logFile extraLogNames level = do +setupLogger :: Maybe FilePath -> [String] -> Priority -> IO () +setupLogger mLogFile extraLogNames level = do - logStream <- openFile logFile AppendMode + logStream <- case mLogFile of + Just logFile -> openFile logFile AppendMode + Nothing -> return stderr hSetEncoding logStream utf8 logH <- LHS.streamHandler logStream level @@ -590,3 +676,26 @@ L.updateGlobalLogger logName $ L.setHandlers [logHandler] L.updateGlobalLogger logName $ L.setLevel level + +-- --------------------------------------------------------------------- + +-- | The changes in a workspace edit should be applied from the end of the file +-- toward the start. Sort them into this order. +reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit +reverseSortEdit (J.WorkspaceEdit cs dcs) = J.WorkspaceEdit cs' dcs' + where + cs' :: Maybe J.WorkspaceEditMap + cs' = (fmap . fmap ) sortTextEdits cs + + dcs' :: Maybe (J.List J.TextDocumentEdit) + dcs' = (fmap . fmap ) sortTextDocumentEdits dcs + + sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit + sortTextEdits (J.List edits) = J.List (L.sortBy down edits) + + sortTextDocumentEdits :: J.TextDocumentEdit -> J.TextDocumentEdit + sortTextDocumentEdits (J.TextDocumentEdit td (J.List edits)) = J.TextDocumentEdit td (J.List edits') + where + edits' = L.sortBy down edits + + down (J.TextEdit r1 _) (J.TextEdit r2 _) = r2 `compare` r1 diff --git a/src/Language/Haskell/LSP/Diagnostics.hs b/src/Language/Haskell/LSP/Diagnostics.hs --- a/src/Language/Haskell/LSP/Diagnostics.hs +++ b/src/Language/Haskell/LSP/Diagnostics.hs @@ -13,12 +13,14 @@ , DiagnosticsBySource , StoreItem(..) , partitionBySource + , flushBySource , updateDiagnostics , getDiagnosticParamsFor -- * for tests ) where +import qualified Data.SortedList as SL import qualified Data.Map as Map import qualified Language.Haskell.LSP.TH.DataTypesJSON as J @@ -43,15 +45,23 @@ = StoreItem (Maybe J.TextDocumentVersion) DiagnosticsBySource deriving (Show,Eq) -type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) [J.Diagnostic] +type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) (SL.SortedList J.Diagnostic) -- --------------------------------------------------------------------- partitionBySource :: [J.Diagnostic] -> DiagnosticsBySource -partitionBySource diags = Map.fromListWith (++) $ map (\d -> (J._source d, [d])) diags +partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, (SL.singleton d))) diags -- --------------------------------------------------------------------- +flushBySource :: DiagnosticStore -> Maybe J.DiagnosticSource -> DiagnosticStore +flushBySource store Nothing = store +flushBySource store (Just source) = Map.map remove store + where + remove (StoreItem mv diags) = StoreItem mv (Map.delete (Just source) diags) + +-- --------------------------------------------------------------------- + updateDiagnostics :: DiagnosticStore -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> DiagnosticStore @@ -60,9 +70,6 @@ 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 @@ -79,11 +86,11 @@ -- --------------------------------------------------------------------- -getDiagnosticParamsFor :: DiagnosticStore -> J.Uri -> Maybe J.PublishDiagnosticsParams -getDiagnosticParamsFor ds uri = +getDiagnosticParamsFor :: Int -> DiagnosticStore -> J.Uri -> Maybe J.PublishDiagnosticsParams +getDiagnosticParamsFor maxDiagnostics ds uri = case Map.lookup uri ds of Nothing -> Nothing Just (StoreItem _ diags) -> - Just $ J.PublishDiagnosticsParams uri (J.List (concat $ Map.elems diags)) + Just $ J.PublishDiagnosticsParams uri (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags)) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/LSP/TH/ClientCapabilities.hs b/src/Language/Haskell/LSP/TH/ClientCapabilities.hs --- a/src/Language/Haskell/LSP/TH/ClientCapabilities.hs +++ b/src/Language/Haskell/LSP/TH/ClientCapabilities.hs @@ -21,13 +21,13 @@ New in 3.0 ---------- -WorkspaceClientCapabilites +WorkspaceClientCapabilities define capabilities the editor / tool provides on the workspace: /** * Workspace specific client capabilities. */ -export interface WorkspaceClientCapabilites { +export interface WorkspaceClientCapabilities { /** * The client supports applying batch edits to the workspace by supporting * the request 'workspace/applyEdit' @@ -140,14 +140,14 @@ -- ------------------------------------- -data WorkspaceClientCapabilites = - WorkspaceClientCapabilites +data WorkspaceClientCapabilities = + WorkspaceClientCapabilities { -- | 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 + , _workspaceEdit :: Maybe WorkspaceEditClientCapabilities -- | Capabilities specific to the `workspace/didChangeConfiguration` notification. , _didChangeConfiguration :: Maybe DidChangeConfigurationClientCapabilities @@ -162,10 +162,10 @@ , _executeCommand :: Maybe ExecuteClientCapabilities } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''WorkspaceClientCapabilites) +$(deriveJSON lspOptions ''WorkspaceClientCapabilities) -instance Default WorkspaceClientCapabilites where - def = WorkspaceClientCapabilites def def def def def def +instance Default WorkspaceClientCapabilities where + def = WorkspaceClientCapabilities def def def def def def -- --------------------------------------------------------------------- {- @@ -614,7 +614,7 @@ /** * Workspace specific client capabilities. */ - workspace?: WorkspaceClientCapabilites; + workspace?: WorkspaceClientCapabilities; /** * Text document specific client capabilities. @@ -630,7 +630,7 @@ data ClientCapabilities = ClientCapabilities - { _workspace :: Maybe WorkspaceClientCapabilites + { _workspace :: Maybe WorkspaceClientCapabilities , _textDocument :: Maybe TextDocumentClientCapabilities , _experimental :: Maybe A.Object } deriving (Show, Read, Eq) diff --git a/src/Language/Haskell/LSP/TH/DataTypesJSON.hs b/src/Language/Haskell/LSP/TH/DataTypesJSON.hs --- a/src/Language/Haskell/LSP/TH/DataTypesJSON.hs +++ b/src/Language/Haskell/LSP/TH/DataTypesJSON.hs @@ -1,36 +1,37 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} module Language.Haskell.LSP.TH.DataTypesJSON where -import Control.Lens.TH ( makeFieldsNoPrefix ) +import Control.Lens.TH (makeFieldsNoPrefix) +import qualified Data.Aeson as A 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 qualified Data.HashMap.Strict as H +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import System.IO (FilePath) +import Data.Char -import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.TH.Constants -import Language.Haskell.LSP.Utility +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) + deriving (Show,Read,Eq,Monoid,Functor) instance (A.ToJSON a) => A.ToJSON (List a) where toJSON (List ls) = toJSON ls @@ -46,11 +47,25 @@ uriToFilePath :: Uri -> Maybe FilePath uriToFilePath (Uri uri) - | "file://" `T.isPrefixOf` uri = Just $ T.unpack $ T.drop n uri + | "file://" `T.isPrefixOf` uri = Just $ platformAdjust . uriDecode . T.unpack $ T.drop n uri | otherwise = Nothing - where n = T.length "file://" + where + n = T.length "file://" + uriDecode ('%':x:y:rest) = toEnum (16 * digitToInt x + digitToInt y) : uriDecode rest + uriDecode (x:xs) = x : uriDecode xs + uriDecode [] = [] + + -- Drop leading '/' for absolute Windows paths + platformAdjust path@('/':_drive:':':_rest) = tail path + platformAdjust path = path + filePathToUri :: FilePath -> Uri +filePathToUri (drive:':':rest) = + Uri $ T.pack $ concat ["file:///", [toLower drive], "%3A", fmap convertDelim rest] + where + convertDelim '\\' = '/' + convertDelim c = c filePathToUri file = Uri $ T.pack $ "file://" ++ file -- --------------------------------------------------------------------- @@ -268,7 +283,7 @@ , _params :: req } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''RequestMessage) +deriveJSON lspOptions ''RequestMessage makeFieldsNoPrefix ''RequestMessage -- --------------------------------------------------------------------- @@ -337,10 +352,10 @@ ResponseError { _code :: ErrorCode , _message :: Text - , _xdata :: Maybe A.Value + , _xdata :: Maybe A.Value } deriving (Read,Show,Eq) -$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ResponseError) +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ResponseError makeFieldsNoPrefix ''ResponseError -- --------------------------------------------------------------------- @@ -353,7 +368,7 @@ , _error :: Maybe ResponseError } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''ResponseMessage) +deriveJSON lspOptions ''ResponseMessage makeFieldsNoPrefix ''ResponseMessage type ErrorResponse = ResponseMessage () @@ -381,7 +396,7 @@ , _params :: a } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''NotificationMessage) +deriveJSON lspOptions ''NotificationMessage makeFieldsNoPrefix ''NotificationMessage -- --------------------------------------------------------------------- @@ -417,7 +432,7 @@ { _id :: LspId } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''CancelParams) +deriveJSON lspOptions ''CancelParams makeFieldsNoPrefix ''CancelParams type CancelNotification = NotificationMessage ClientMethod CancelParams @@ -454,11 +469,11 @@ -} data Position = Position - { _line :: Int - , _character :: Int + { _line :: Int + , _character :: Int } deriving (Show, Read, Eq, Ord) -$(deriveJSON lspOptions ''Position) +deriveJSON lspOptions ''Position makeFieldsNoPrefix ''Position -- --------------------------------------------------------------------- @@ -488,7 +503,7 @@ , _end :: Position } deriving (Show, Read, Eq, Ord) -$(deriveJSON lspOptions ''Range) +deriveJSON lspOptions ''Range makeFieldsNoPrefix ''Range -- --------------------------------------------------------------------- @@ -509,7 +524,7 @@ , _range :: Range } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''Location) +deriveJSON lspOptions ''Location makeFieldsNoPrefix ''Location -- --------------------------------------------------------------------- @@ -604,7 +619,7 @@ , _message :: Text } deriving (Show, Read, Eq, Ord) -$(deriveJSON lspOptions ''Diagnostic) +deriveJSON lspOptions ''Diagnostic makeFieldsNoPrefix ''Diagnostic -- --------------------------------------------------------------------- @@ -642,7 +657,7 @@ , _arguments :: Maybe A.Value } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''Command) +deriveJSON lspOptions ''Command makeFieldsNoPrefix ''Command -- --------------------------------------------------------------------- @@ -676,7 +691,7 @@ , _newText :: Text } deriving (Show,Read,Eq) -$(deriveJSON lspOptions ''TextEdit) +deriveJSON lspOptions ''TextEdit makeFieldsNoPrefix ''TextEdit -- --------------------------------------------------------------------- @@ -702,7 +717,7 @@ , _version :: TextDocumentVersion } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''VersionedTextDocumentIdentifier) +deriveJSON lspOptions ''VersionedTextDocumentIdentifier makeFieldsNoPrefix ''VersionedTextDocumentIdentifier -- --------------------------------------------------------------------- @@ -738,7 +753,7 @@ , _edits :: List TextEdit } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentEdit) +deriveJSON lspOptions ''TextDocumentEdit makeFieldsNoPrefix ''TextDocumentEdit -- --------------------------------------------------------------------- @@ -765,7 +780,7 @@ /** * 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`. + * edits is expressed via `WorkspaceClientCapabilities.versionedWorkspaceEdit`. */ documentChanges?: TextDocumentEdit[]; } @@ -783,7 +798,7 @@ mempty = WorkspaceEdit Nothing Nothing mappend (WorkspaceEdit a b) (WorkspaceEdit c d) = WorkspaceEdit (a <> c) (b <> d) -$(deriveJSON lspOptions ''WorkspaceEdit) +deriveJSON lspOptions ''WorkspaceEdit makeFieldsNoPrefix ''WorkspaceEdit -- --------------------------------------------------------------------- @@ -807,7 +822,7 @@ { _uri :: Uri } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentIdentifier) +deriveJSON lspOptions ''TextDocumentIdentifier makeFieldsNoPrefix ''TextDocumentIdentifier -- --------------------------------------------------------------------- @@ -851,7 +866,7 @@ , _text :: Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentItem) +deriveJSON lspOptions ''TextDocumentItem makeFieldsNoPrefix ''TextDocumentItem -- --------------------------------------------------------------------- @@ -882,7 +897,7 @@ , _position :: Position } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentPositionParams) +deriveJSON lspOptions ''TextDocumentPositionParams makeFieldsNoPrefix ''TextDocumentPositionParams -- --------------------------------------------------------------------- @@ -924,7 +939,7 @@ , _pattern :: Maybe Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DocumentFilter) +deriveJSON lspOptions ''DocumentFilter makeFieldsNoPrefix ''DocumentFilter {- @@ -1020,7 +1035,7 @@ } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''InitializeParams) +deriveJSON lspOptions ''InitializeParams makeFieldsNoPrefix ''InitializeParams -- --------------------------------------------------------------------- @@ -1044,7 +1059,7 @@ { _retry :: Bool } deriving (Read, Show, Eq) -$(deriveJSON lspOptions ''InitializeError) +deriveJSON lspOptions ''InitializeError makeFieldsNoPrefix ''InitializeError -- --------------------------------------------------------------------- @@ -1113,7 +1128,7 @@ , _triggerCharacters :: Maybe [String] } deriving (Read,Show,Eq) -$(deriveJSON lspOptions {omitNothingFields = True } ''CompletionOptions) +deriveJSON lspOptions {omitNothingFields = True } ''CompletionOptions makeFieldsNoPrefix ''CompletionOptions -- --------------------------------------------------------------------- @@ -1133,7 +1148,7 @@ { _triggerCharacters :: Maybe [String] } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''SignatureHelpOptions) +deriveJSON lspOptions ''SignatureHelpOptions makeFieldsNoPrefix ''SignatureHelpOptions -- --------------------------------------------------------------------- @@ -1154,7 +1169,7 @@ { _resolveProvider :: Maybe Bool } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''CodeLensOptions) +deriveJSON lspOptions ''CodeLensOptions makeFieldsNoPrefix ''CodeLensOptions -- --------------------------------------------------------------------- @@ -1179,7 +1194,7 @@ , _moreTriggerCharacter :: Maybe [String] } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DocumentOnTypeFormattingOptions) +deriveJSON lspOptions ''DocumentOnTypeFormattingOptions makeFieldsNoPrefix ''DocumentOnTypeFormattingOptions -- --------------------------------------------------------------------- @@ -1204,7 +1219,7 @@ _resolveProvider :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DocumentLinkOptions) +deriveJSON lspOptions ''DocumentLinkOptions makeFieldsNoPrefix ''DocumentLinkOptions -- --------------------------------------------------------------------- @@ -1230,7 +1245,7 @@ _commands :: List Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ExecuteCommandOptions) +deriveJSON lspOptions ''ExecuteCommandOptions makeFieldsNoPrefix ''ExecuteCommandOptions -- --------------------------------------------------------------------- @@ -1253,7 +1268,7 @@ _includeText :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''SaveOptions) +deriveJSON lspOptions ''SaveOptions makeFieldsNoPrefix ''SaveOptions -- --------------------------------------------------------------------- @@ -1289,24 +1304,24 @@ data TextDocumentSyncOptions = TextDocumentSyncOptions { -- | Open and close notifications are sent to the server. - _openClose :: Maybe Bool + _openClose :: Maybe Bool -- | Change notificatins are sent to the server. See -- TextDocumentSyncKind.None, TextDocumentSyncKind.Full and -- TextDocumentSyncKindIncremental. - , _change :: Maybe TextDocumentSyncKind + , _change :: Maybe TextDocumentSyncKind -- | Will save notifications are sent to the server. - , _willSave :: Maybe Bool + , _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 + , _save :: Maybe SaveOptions } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentSyncOptions) +deriveJSON lspOptions ''TextDocumentSyncOptions makeFieldsNoPrefix ''TextDocumentSyncOptions -- --------------------------------------------------------------------- @@ -1394,7 +1409,7 @@ data InitializeResponseCapabilitiesInner = InitializeResponseCapabilitiesInner - { _textDocumentSync :: Maybe TextDocumentSyncKind + { _textDocumentSync :: Maybe TextDocumentSyncOptions , _hoverProvider :: Maybe Bool , _completionProvider :: Maybe CompletionOptions , _signatureHelpProvider :: Maybe SignatureHelpOptions @@ -1415,7 +1430,7 @@ , _experimental :: Maybe A.Value } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''InitializeResponseCapabilitiesInner) +deriveJSON lspOptions ''InitializeResponseCapabilitiesInner makeFieldsNoPrefix ''InitializeResponseCapabilitiesInner @@ -1428,7 +1443,7 @@ _capabilities :: InitializeResponseCapabilitiesInner } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''InitializeResponseCapabilities) +deriveJSON lspOptions ''InitializeResponseCapabilities makeFieldsNoPrefix ''InitializeResponseCapabilities -- --------------------------------------------------------------------- @@ -1541,14 +1556,14 @@ -- | -- Notification from the server to actually exit now, after shutdown acked -- -data ExitNotificationParams = - ExitNotificationParams +data ExitParams = + ExitParams { } deriving (Show, Read, Eq) -$(deriveJSON defaultOptions ''ExitNotificationParams) +deriveJSON defaultOptions ''ExitParams -type ExitNotification = NotificationMessage ClientMethod (Maybe ExitNotificationParams) +type ExitNotification = NotificationMessage ClientMethod (Maybe ExitParams) -- --------------------------------------------------------------------- {- @@ -1621,11 +1636,11 @@ data ShowMessageParams = ShowMessageParams { - _xtype :: MessageType + _xtype :: MessageType , _message :: Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageParams) +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageParams makeFieldsNoPrefix ''ShowMessageParams type ShowMessageNotification = NotificationMessage ServerMethod ShowMessageParams @@ -1683,18 +1698,18 @@ { _title :: Text } deriving (Show,Read,Eq) -$(deriveJSON lspOptions ''MessageActionItem) +deriveJSON lspOptions ''MessageActionItem makeFieldsNoPrefix ''MessageActionItem data ShowMessageRequestParams = ShowMessageRequestParams - { _xtype :: MessageType + { _xtype :: MessageType , _message :: Text , _actions :: Maybe [MessageActionItem] } deriving (Show,Read,Eq) -$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageRequestParams) +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''ShowMessageRequestParams makeFieldsNoPrefix ''ShowMessageRequestParams type ShowMessageRequest = RequestMessage ServerMethod ShowMessageRequestParams Text @@ -1731,11 +1746,11 @@ data LogMessageParams = LogMessageParams { - _xtype :: MessageType + _xtype :: MessageType , _message :: Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''LogMessageParams) +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''LogMessageParams makeFieldsNoPrefix ''LogMessageParams @@ -1808,16 +1823,16 @@ Registration { -- |The id used to register the request. The id can be used to deregister -- the request again. - _id :: Text + _id :: Text -- | The method / capability to register for. - , _method :: ClientMethod + , _method :: ClientMethod -- | Options necessary for the registration. , _registerOptions :: Maybe A.Value } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''Registration) +deriveJSON lspOptions ''Registration makeFieldsNoPrefix ''Registration data RegistrationParams = @@ -1825,7 +1840,7 @@ { _registrations :: List Registration } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''RegistrationParams) +deriveJSON lspOptions ''RegistrationParams makeFieldsNoPrefix ''RegistrationParams -- |Note: originates at the server @@ -1851,7 +1866,7 @@ { _documentSelector :: Maybe DocumentSelector } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentRegistrationOptions) +deriveJSON lspOptions ''TextDocumentRegistrationOptions makeFieldsNoPrefix ''TextDocumentRegistrationOptions -- --------------------------------------------------------------------- @@ -1896,13 +1911,13 @@ Unregistration { -- | The id used to unregister the request or notification. Usually an id -- provided during the register request. - _id :: Text + _id :: Text -- |The method / capability to unregister for. , _method :: Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''Unregistration) +deriveJSON lspOptions ''Unregistration makeFieldsNoPrefix ''Unregistration data UnregistrationParams = @@ -1910,7 +1925,7 @@ { _unregistrations :: List Unregistration } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''UnregistrationParams) +deriveJSON lspOptions ''UnregistrationParams makeFieldsNoPrefix ''UnregistrationParams type UnregisterCapabilityRequest = RequestMessage ServerMethod UnregistrationParams () @@ -1942,7 +1957,7 @@ _settings :: A.Value } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DidChangeConfigurationParams) +deriveJSON lspOptions ''DidChangeConfigurationParams makeFieldsNoPrefix ''DidChangeConfigurationParams @@ -1979,7 +1994,7 @@ _textDocument :: TextDocumentItem } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DidOpenTextDocumentParams) +deriveJSON lspOptions ''DidOpenTextDocumentParams makeFieldsNoPrefix ''DidOpenTextDocumentParams type DidOpenTextDocumentNotification = NotificationMessage ClientMethod DidOpenTextDocumentParams @@ -2041,7 +2056,7 @@ , _text :: Text } deriving (Read,Show,Eq) -$(deriveJSON lspOptions { omitNothingFields = True } ''TextDocumentContentChangeEvent) +deriveJSON lspOptions { omitNothingFields = True } ''TextDocumentContentChangeEvent makeFieldsNoPrefix ''TextDocumentContentChangeEvent -- ------------------------------------- @@ -2052,7 +2067,7 @@ , _contentChanges :: List TextDocumentContentChangeEvent } deriving (Show,Read,Eq) -$(deriveJSON lspOptions ''DidChangeTextDocumentParams) +deriveJSON lspOptions ''DidChangeTextDocumentParams makeFieldsNoPrefix ''DidChangeTextDocumentParams type DidChangeTextDocumentNotification = NotificationMessage ClientMethod DidChangeTextDocumentParams @@ -2080,7 +2095,7 @@ , _syncKind :: TextDocumentSyncKind } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions) +deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions makeFieldsNoPrefix ''TextDocumentChangeRegistrationOptions -- --------------------------------------------------------------------- @@ -2163,7 +2178,7 @@ , _reason :: TextDocumentSaveReason } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''WillSaveTextDocumentParams) +deriveJSON lspOptions ''WillSaveTextDocumentParams makeFieldsNoPrefix ''WillSaveTextDocumentParams type WillSaveTextDocumentNotification = NotificationMessage ClientMethod WillSaveTextDocumentParams @@ -2222,7 +2237,7 @@ { _textDocument :: TextDocumentIdentifier } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DidSaveTextDocumentParams) +deriveJSON lspOptions ''DidSaveTextDocumentParams makeFieldsNoPrefix ''DidSaveTextDocumentParams type DidSaveTextDocumentNotification = NotificationMessage ClientMethod DidSaveTextDocumentParams @@ -2260,7 +2275,7 @@ { _textDocument :: TextDocumentIdentifier } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DidCloseTextDocumentParams) +deriveJSON lspOptions ''DidCloseTextDocumentParams makeFieldsNoPrefix ''DidCloseTextDocumentParams @@ -2341,11 +2356,11 @@ data FileEvent = FileEvent - { _uri :: Uri + { _uri :: Uri , _xtype :: FileChangeType } deriving (Read,Show,Eq) -$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''FileEvent) +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''FileEvent makeFieldsNoPrefix ''FileEvent data DidChangeWatchedFilesParams = @@ -2353,7 +2368,7 @@ { _params :: List FileEvent } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DidChangeWatchedFilesParams) +deriveJSON lspOptions ''DidChangeWatchedFilesParams makeFieldsNoPrefix ''DidChangeWatchedFilesParams @@ -2392,7 +2407,7 @@ , _diagnostics :: List Diagnostic } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''PublishDiagnosticsParams) +deriveJSON lspOptions ''PublishDiagnosticsParams makeFieldsNoPrefix ''PublishDiagnosticsParams @@ -2596,13 +2611,13 @@ deriving (Show, Read, Eq) instance A.ToJSON InsertTextFormat where - toJSON PlainText = A.Number 1 - toJSON Snippet = A.Number 2 + 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 + parseJSON _ = mempty -- ------------------------------------- @@ -2665,36 +2680,36 @@ parseJSON (A.Number 16) = pure CiColor parseJSON (A.Number 17) = pure CiFile parseJSON (A.Number 18) = pure CiReference - parseJSON _ = mempty + parseJSON _ = mempty -- ------------------------------------- data CompletionItem = CompletionItem - { _label :: Text -- ^ The label of this completion item. By default also + { _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 + , _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 + , _documentation :: Maybe Text -- ^ A human-readable string that represents -- a doc-comment. - , _sortText :: Maybe Text -- ^ A string that should be used when filtering + , _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 + , _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 + , _insertText :: Maybe Text -- ^ A string that should be inserted a -- document when selecting this completion. -- When `falsy` the label is used. - , _insertTextFormat :: Maybe InsertTextFormat + , _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 + , _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. @@ -2705,25 +2720,25 @@ -- ^ 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 + , _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 + , _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) +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CompletionItem makeFieldsNoPrefix ''CompletionItem data CompletionListType = CompletionListType { _isIncomplete :: Bool - , _items :: List CompletionItem + , _items :: List CompletionItem } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''CompletionListType) +deriveJSON lspOptions ''CompletionListType makeFieldsNoPrefix ''CompletionListType @@ -2732,7 +2747,7 @@ | Completions (List CompletionItem) deriving (Read,Show,Eq) -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length ("CompletionResponseResult"::String)), sumEncoding = UntaggedValue } ''CompletionResponseResult) +deriveJSON defaultOptions { fieldLabelModifier = rdrop (length ("CompletionResponseResult"::String)), sumEncoding = UntaggedValue } ''CompletionResponseResult type CompletionResponse = ResponseMessage CompletionResponseResult type CompletionRequest = RequestMessage ClientMethod TextDocumentPositionParams CompletionResponseResult @@ -2764,7 +2779,7 @@ , _resolveProvider :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''CompletionRegistrationOptions) +deriveJSON lspOptions ''CompletionRegistrationOptions makeFieldsNoPrefix ''CompletionRegistrationOptions -- --------------------------------------------------------------------- @@ -2854,7 +2869,7 @@ , _value :: Text } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''LanguageString) +deriveJSON lspOptions ''LanguageString makeFieldsNoPrefix ''LanguageString data MarkedString = @@ -2867,7 +2882,7 @@ toJSON (CodeString x) = toJSON x instance FromJSON MarkedString where parseJSON (A.String t) = pure $ PlainString t - parseJSON o = CodeString <$> parseJSON o + parseJSON o = CodeString <$> parseJSON o data Hover = Hover @@ -2875,7 +2890,7 @@ , _range :: Maybe Range } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''Hover) +deriveJSON lspOptions ''Hover makeFieldsNoPrefix ''Hover @@ -2978,7 +2993,7 @@ { _label :: Text , _documentation :: Maybe Text } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''ParameterInformation) +deriveJSON lspOptions ''ParameterInformation makeFieldsNoPrefix ''ParameterInformation @@ -2991,7 +3006,7 @@ , _parameters :: Maybe [ParameterInformation] } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''SignatureInformation) +deriveJSON lspOptions ''SignatureInformation makeFieldsNoPrefix ''SignatureInformation data SignatureHelp = @@ -3001,7 +3016,7 @@ , _activeParameter :: Maybe Int -- ^ The active parameter of the active signature } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''SignatureHelp) +deriveJSON lspOptions ''SignatureHelp makeFieldsNoPrefix ''SignatureHelp type SignatureHelpRequest = RequestMessage ClientMethod TextDocumentPositionParams SignatureHelp @@ -3028,7 +3043,7 @@ , _triggerCharacters :: Maybe (List String) } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''SignatureHelpRegistrationOptions) +deriveJSON lspOptions ''SignatureHelpRegistrationOptions makeFieldsNoPrefix ''SignatureHelpRegistrationOptions -- --------------------------------------------------------------------- @@ -3059,9 +3074,20 @@ -- {"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 +data DefinitionResponseParams = SingleLoc Location | MultiLoc [Location] + deriving (Eq,Read,Show) +instance A.ToJSON DefinitionResponseParams where + toJSON (SingleLoc x) = toJSON x + toJSON (MultiLoc xs) = toJSON xs + +instance A.FromJSON DefinitionResponseParams where + parseJSON xs@(A.Array _) = MultiLoc <$> parseJSON xs + parseJSON x = SingleLoc <$> parseJSON x + +type DefinitionRequest = RequestMessage ClientMethod TextDocumentPositionParams DefinitionResponseParams +type DefinitionResponse = ResponseMessage DefinitionResponseParams + -- --------------------------------------------------------------------- {- @@ -3105,7 +3131,7 @@ { _includeDeclaration :: Bool } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''ReferenceContext) +deriveJSON lspOptions ''ReferenceContext makeFieldsNoPrefix ''ReferenceContext @@ -3116,7 +3142,7 @@ , _context :: ReferenceContext } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''ReferenceParams) +deriveJSON lspOptions ''ReferenceParams makeFieldsNoPrefix ''ReferenceParams @@ -3217,7 +3243,7 @@ , _kind :: Maybe DocumentHighlightKind } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DocumentHighlight) +deriveJSON lspOptions ''DocumentHighlight makeFieldsNoPrefix ''DocumentHighlight type DocumentHighlightRequest = RequestMessage ClientMethod TextDocumentPositionParams (List DocumentHighlight) @@ -3314,7 +3340,7 @@ { _textDocument :: TextDocumentIdentifier } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DocumentSymbolParams) +deriveJSON lspOptions ''DocumentSymbolParams makeFieldsNoPrefix ''DocumentSymbolParams -- ------------------------------------- @@ -3393,7 +3419,7 @@ -- symbol. } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''SymbolInformation) +deriveJSON lspOptions ''SymbolInformation makeFieldsNoPrefix ''SymbolInformation @@ -3438,7 +3464,7 @@ { _query :: Text } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''WorkspaceSymbolParams) +deriveJSON lspOptions ''WorkspaceSymbolParams makeFieldsNoPrefix ''WorkspaceSymbolParams type WorkspaceSymbolRequest = RequestMessage ClientMethod WorkspaceSymbolParams (List SymbolInformation) @@ -3504,7 +3530,7 @@ { _diagnostics :: List Diagnostic } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''CodeActionContext) +deriveJSON lspOptions ''CodeActionContext makeFieldsNoPrefix ''CodeActionContext @@ -3515,7 +3541,7 @@ , _context :: CodeActionContext } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''CodeActionParams) +deriveJSON lspOptions ''CodeActionParams makeFieldsNoPrefix ''CodeActionParams @@ -3581,7 +3607,7 @@ { _textDocument :: TextDocumentIdentifier } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''CodeLensParams) +deriveJSON lspOptions ''CodeLensParams makeFieldsNoPrefix ''CodeLensParams @@ -3591,10 +3617,10 @@ CodeLens { _range :: Range , _command :: Maybe Command - , _xdata :: Maybe A.Value + , _xdata :: Maybe A.Value } deriving (Read,Show,Eq) -$(deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens) +deriveJSON lspOptions{ fieldLabelModifier = customModifier } ''CodeLens makeFieldsNoPrefix ''CodeLens @@ -3619,7 +3645,7 @@ , _resolveProvider :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''CodeLensRegistrationOptions) +deriveJSON lspOptions ''CodeLensRegistrationOptions makeFieldsNoPrefix ''CodeLensRegistrationOptions -- --------------------------------------------------------------------- @@ -3706,16 +3732,16 @@ { _textDocument :: TextDocumentIdentifier } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DocumentLinkParams) +deriveJSON lspOptions ''DocumentLinkParams makeFieldsNoPrefix ''DocumentLinkParams data DocumentLink = DocumentLink - { _range :: Range + { _range :: Range , _target :: Maybe Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DocumentLink) +deriveJSON lspOptions ''DocumentLink makeFieldsNoPrefix ''DocumentLink type DocumentLinkRequest = RequestMessage ClientMethod DocumentLinkParams (List DocumentLink) @@ -3808,7 +3834,7 @@ -- Note: May be more properties } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''FormattingOptions) +deriveJSON lspOptions ''FormattingOptions makeFieldsNoPrefix ''FormattingOptions data DocumentFormattingParams = @@ -3817,7 +3843,7 @@ , _options :: FormattingOptions } deriving (Show,Read,Eq) -$(deriveJSON lspOptions ''DocumentFormattingParams) +deriveJSON lspOptions ''DocumentFormattingParams makeFieldsNoPrefix ''DocumentFormattingParams type DocumentFormattingRequest = RequestMessage ClientMethod DocumentFormattingParams (List TextEdit) @@ -3869,7 +3895,7 @@ , _options :: FormattingOptions } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DocumentRangeFormattingParams) +deriveJSON lspOptions ''DocumentRangeFormattingParams makeFieldsNoPrefix ''DocumentRangeFormattingParams type DocumentRangeFormattingRequest = RequestMessage ClientMethod DocumentRangeFormattingParams (List TextEdit) @@ -3939,7 +3965,7 @@ , _options :: FormattingOptions } deriving (Read,Show,Eq) -$(deriveJSON lspOptions ''DocumentOnTypeFormattingParams) +deriveJSON lspOptions ''DocumentOnTypeFormattingParams makeFieldsNoPrefix ''DocumentOnTypeFormattingParams type DocumentOnTypeFormattingRequest = RequestMessage ClientMethod DocumentOnTypeFormattingParams (List TextEdit) @@ -3951,7 +3977,7 @@ , _moreTriggerCharacter :: Maybe (List String) } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''DocumentOnTypeFormattingRegistrationOptions) +deriveJSON lspOptions ''DocumentOnTypeFormattingRegistrationOptions -- --------------------------------------------------------------------- {- @@ -4002,7 +4028,7 @@ , _newName :: Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''RenameParams) +deriveJSON lspOptions ''RenameParams makeFieldsNoPrefix ''RenameParams @@ -4064,11 +4090,11 @@ data ExecuteCommandParams = ExecuteCommandParams - { _command :: Text + { _command :: Text , _arguments :: Maybe (List A.Value) } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ExecuteCommandParams) +deriveJSON lspOptions ''ExecuteCommandParams makeFieldsNoPrefix ''ExecuteCommandParams type ExecuteCommandRequest = RequestMessage ClientMethod ExecuteCommandParams A.Value @@ -4079,7 +4105,7 @@ { _commands :: List Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ExecuteCommandRegistrationOptions) +deriveJSON lspOptions ''ExecuteCommandRegistrationOptions makeFieldsNoPrefix ''ExecuteCommandRegistrationOptions -- --------------------------------------------------------------------- @@ -4123,7 +4149,7 @@ { _edit :: WorkspaceEdit } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ApplyWorkspaceEditParams) +deriveJSON lspOptions ''ApplyWorkspaceEditParams makeFieldsNoPrefix ''ApplyWorkspaceEditParams data ApplyWorkspaceEditResponseBody = @@ -4131,7 +4157,7 @@ { _applied :: Bool } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''ApplyWorkspaceEditResponseBody) +deriveJSON lspOptions ''ApplyWorkspaceEditResponseBody makeFieldsNoPrefix ''ApplyWorkspaceEditResponseBody -- | Sent from the server to the client @@ -4142,21 +4168,21 @@ -- --------------------------------------------------------------------- -data TraceNotificationParams = - TraceNotificationParams { +data TraceParams = + TraceParams { _value :: Text } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TraceNotificationParams) -makeFieldsNoPrefix ''TraceNotificationParams +deriveJSON lspOptions ''TraceParams +makeFieldsNoPrefix ''TraceParams data TraceNotification = TraceNotification { - _params :: TraceNotificationParams + _params :: TraceParams } deriving (Show, Read, Eq) -$(deriveJSON lspOptions ''TraceNotification) +deriveJSON lspOptions ''TraceNotification makeFieldsNoPrefix ''TraceNotification diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -17,6 +17,7 @@ , closeVFS -- * for tests + , applyChange , sortChanges , deleteChars , addChars , changeChars @@ -25,6 +26,7 @@ import Data.Text ( Text ) import Data.List +import Data.Monoid import qualified Data.Map as Map import qualified Language.Haskell.LSP.TH.DataTypesJSON as J import Language.Haskell.LSP.Utility @@ -103,13 +105,18 @@ 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 + -- Note: changeChars 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 (Just r@(J.Range (J.Position sl sc) (J.Position el ec))) Nothing txt) + = applyChange str (J.TextDocumentContentChangeEvent (Just r) (Just len) txt) + where len = Yi.length region + (beforeEnd, afterEnd) = Yi.splitAtLine el str + lastLine = Yi.take ec afterEnd + lastLine' | sl == el = Yi.drop sc lastLine + | otherwise = lastLine + (_beforeStart, afterStartBeforeEnd) = Yi.splitAtLine sl beforeEnd + region = Yi.drop sc afterStartBeforeEnd <> lastLine' applyChange str (J.TextDocumentContentChangeEvent Nothing (Just _) _txt) = str diff --git a/test/DiagnosticsSpec.hs b/test/DiagnosticsSpec.hs --- a/test/DiagnosticsSpec.hs +++ b/test/DiagnosticsSpec.hs @@ -3,7 +3,7 @@ import qualified Data.Map as Map --- import qualified Data.Text as T +import qualified Data.SortedList as SL import Data.Text ( Text ) import Language.Haskell.LSP.Diagnostics import qualified Language.Haskell.LSP.TH.DataTypesJSON as J @@ -29,6 +29,9 @@ 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 +mkDiagnostic2 :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic2 ms str = J.Diagnostic (J.Range (J.Position 4 1) (J.Position 5 0)) Nothing Nothing ms str + -- --------------------------------------------------------------------- diagnosticsSpec :: Spec @@ -42,7 +45,7 @@ ] (updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags)) `shouldBe` Map.fromList - [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList [(Just "hlint", reverse diags) ] ) + [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags) ] ) ] -- --------------------------------- @@ -56,8 +59,8 @@ (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"]) + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) ]) ] @@ -72,8 +75,8 @@ (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"]) + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) ]) ] @@ -92,7 +95,7 @@ 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) ] ) + [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) ] -- --------------------------------- @@ -110,8 +113,8 @@ (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"]) + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) + ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b1")) ] ) ] @@ -124,11 +127,11 @@ , 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` + (updateDiagnostics origStore (J.Uri "uri") Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])) `shouldBe` Map.fromList [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList - [(Just "ghcmod", []) - ,(Just "hlint", [mkDiagnostic (Just "hlint") "a1"]) + [(Just "ghcmod", SL.toSortedList []) + ,(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a1")) ] ) ] @@ -148,7 +151,7 @@ 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) ] ) + [ ((J.Uri "uri"),StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) ] -- --------------------------------- @@ -166,7 +169,7 @@ (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"]) + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) ] ) ] @@ -181,7 +184,63 @@ , mkDiagnostic (Just "ghcmod") "b" ] let ds = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags) - (getDiagnosticParamsFor ds (J.Uri "uri")) `shouldBe` + (getDiagnosticParamsFor 10 ds (J.Uri "uri")) `shouldBe` Just (J.PublishDiagnosticsParams (J.Uri "uri") (J.List $ reverse diags)) + + -- --------------------------------- + + describe "limits the number of diagnostics retrieved, in order" $ do + + it "gets diagnostics for multiple sources" $ do + let + diags = + [ mkDiagnostic2 (Just "hlint") "a" + , mkDiagnostic2 (Just "ghcmod") "b" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" + ] + let ds = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags) + (getDiagnosticParamsFor 2 ds (J.Uri "uri")) `shouldBe` + Just (J.PublishDiagnosticsParams (J.Uri "uri") + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + ])) + + (getDiagnosticParamsFor 1 ds (J.Uri "uri")) `shouldBe` + Just (J.PublishDiagnosticsParams (J.Uri "uri") + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + ])) + + -- --------------------------------- + + describe "flushes the diagnostics for a given source" $ do + + it "gets diagnostics for multiple sources" $ do + let + diags = + [ mkDiagnostic2 (Just "hlint") "a" + , mkDiagnostic2 (Just "ghcmod") "b" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" + ] + let ds = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags) + (getDiagnosticParamsFor 100 ds (J.Uri "uri")) `shouldBe` + Just (J.PublishDiagnosticsParams (J.Uri "uri") + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic2 (Just "ghcmod") "b" + , mkDiagnostic2 (Just "hlint") "a" + ])) + + let ds' = flushBySource ds (Just "hlint") + (getDiagnosticParamsFor 100 ds' (J.Uri "uri")) `shouldBe` + Just (J.PublishDiagnosticsParams (J.Uri "uri") + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic2 (Just "ghcmod") "b" + ])) -- --------------------------------- diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -56,7 +56,8 @@ , "-- fooo" , "foo :: Int" ] - new = deleteChars (Yi.fromString orig) (J.Position 2 1) 4 + new = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 1 2 5) (Just 4) "" lines (Yi.toString new) `shouldBe` [ "abcdg" , "module Foo where" @@ -64,6 +65,23 @@ , "foo :: Int" ] + it "deletes characters within a line (no len)" $ do + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 1 2 5) Nothing "" + lines (Yi.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "-oo" + , "foo :: Int" + ] + -- --------------------------------- it "deletes one line" $ do @@ -75,12 +93,30 @@ , "-- fooo" , "foo :: Int" ] - new = deleteChars (Yi.fromString orig) (J.Position 2 0) 8 + new = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) (Just 8) "" lines (Yi.toString new) `shouldBe` [ "abcdg" , "module Foo where" , "foo :: Int" ] + + it "deletes one line(no len)" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "" + lines (Yi.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] -- --------------------------------- it "deletes two lines" $ do @@ -92,12 +128,28 @@ , "foo :: Int" , "foo = bb" ] - new = deleteChars (Yi.fromString orig) (J.Position 1 0) 19 + new = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 1 0 3 0) (Just 19) "" lines (Yi.toString new) `shouldBe` [ "module Foo where" , "foo = bb" ] + it "deletes two lines(no len)" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + new = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 1 0 3 0) Nothing "" + lines (Yi.toString new) `shouldBe` + [ "module Foo where" + , "foo = bb" + ] -- --------------------------------- describe "adds characters" $ do @@ -152,7 +204,36 @@ , " 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 =" + new = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 7 0 7 8) (Just 8) "baz =" + lines (Yi.toString new) `shouldBe` + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz =" + , " putStrLn \"hello world\"" + ] + it "removes end of a line(no len)" $ 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 = applyChange (Yi.fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 7 0 7 8) Nothing "baz =" lines (Yi.toString new) `shouldBe` [ "module Foo where" , "-- fooo"