haskell-lsp 0.1.0.0 → 0.2.0.0
raw patch · 13 files changed
+626/−330 lines, 13 filesdep +sorted-list
Dependencies added: sorted-list
Files
- ChangeLog.md +4/−0
- README.md +4/−1
- example/Main.hs +25/−30
- haskell-lsp.cabal +6/−4
- src/Language/Haskell/LSP/Constant.hs +2/−1
- src/Language/Haskell/LSP/Control.hs +14/−12
- src/Language/Haskell/LSP/Core.hs +196/−87
- src/Language/Haskell/LSP/Diagnostics.hs +15/−8
- src/Language/Haskell/LSP/TH/ClientCapabilities.hs +10/−10
- src/Language/Haskell/LSP/TH/DataTypesJSON.hs +179/−153
- src/Language/Haskell/LSP/VFS.hs +12/−5
- test/DiagnosticsSpec.hs +74/−15
- test/VspSpec.hs +85/−4
ChangeLog.md view
@@ -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
README.md view
@@ -1,3 +1,6 @@+[](https://circleci.com/gh/alanz/haskell-lsp)+[](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
example/Main.hs view
@@ -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"])) }
haskell-lsp.cabal view
@@ -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
src/Language/Haskell/LSP/Constant.hs view
@@ -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"
src/Language/Haskell/LSP/Control.hs view
@@ -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"
src/Language/Haskell/LSP/Core.hs view
@@ -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
src/Language/Haskell/LSP/Diagnostics.hs view
@@ -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)) -- ---------------------------------------------------------------------
src/Language/Haskell/LSP/TH/ClientCapabilities.hs view
@@ -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)
src/Language/Haskell/LSP/TH/DataTypesJSON.hs view
@@ -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
src/Language/Haskell/LSP/VFS.hs view
@@ -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
test/DiagnosticsSpec.hs view
@@ -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"+ ])) -- ---------------------------------
test/VspSpec.hs view
@@ -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"