diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for haskell-lsp +## 0.17.0.0 -- 2019-10-18 + +* Update progress reporting to match the LSP 3.15 specification (@cocreature) +* Fix progress cancellation action being retained (@mpickering) +* Respect both codeActionProvider and codeActionHandler in server + capabilities (@fendor) +* Ensure ResponseMessage has either a result or an error (@cocreature) + ## 0.16.0.0 -- 2019-09-07 * Add support for CodeActionOptions (@thomasjm) 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.16.0.0 +version: 0.17.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -46,7 +46,7 @@ , filepath , hslogger , hashable - , haskell-lsp-types == 0.16.* + , haskell-lsp-types == 0.17.* , lens >= 4.15.2 , mtl , network-uri 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 @@ -91,7 +91,7 @@ } data ProgressData = ProgressData { progressNextId :: !Int - , progressCancel :: !(Map.Map Text (IO ())) } + , progressCancel :: !(Map.Map J.ProgressToken (IO ())) } -- --------------------------------------------------------------------- @@ -370,7 +370,7 @@ handlerMap _ h J.TextDocumentRename = hh nop ReqRename $ renameHandler h handlerMap _ h J.TextDocumentPrepareRename = hh nop ReqPrepareRename $ prepareRenameHandler h handlerMap _ h J.TextDocumentFoldingRange = hh nop ReqFoldingRange $ foldingRangeHandler h -handlerMap _ _ J.WindowProgressCancel = helper progressCancelHandler +handlerMap _ _ J.WorkDoneProgressCancel = helper progressCancelHandler handlerMap _ h (J.CustomClientMethod _) = \ctxData val -> case val of J.Object o | "id" `HM.member` o -> @@ -732,20 +732,27 @@ (C.WindowClientCapabilities mProgress) <- wc mProgress - storeProgress :: Text -> Async a -> IO () + storeProgress :: J.ProgressToken -> Async a -> IO () storeProgress n a = atomically $ do pd <- resProgressData <$> readTVar tvarCtx let pc = progressCancel pd pc' = Map.insert n (cancelWith a ProgressCancelledException) pc modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressCancel = pc' }}) + deleteProgress :: J.ProgressToken -> IO () + deleteProgress n = atomically $ do + pd <- resProgressData <$> readTVar tvarCtx + let x = progressCancel pd + x' = Map.delete n x + modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressCancel = x' }}) + -- Get a new id for the progress session and make a new one - getNewProgressId :: IO Text - getNewProgressId = fmap (T.pack . show) $ liftIO $ atomically $ do + getNewProgressId :: IO J.ProgressToken + getNewProgressId = liftIO $ atomically $ do pd <- resProgressData <$> readTVar tvarCtx let x = progressNextId pd modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressNextId = x + 1 }}) - return x + return $ J.ProgressNumericToken x withProgressBase :: Bool -> (Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a) @@ -762,24 +769,36 @@ Cancellable -> True NotCancellable -> False + rId <- getLspId $ resLspId ctx0 + + -- Create progress token + liftIO $ sf $ ReqWorkDoneProgressCreate $ + fmServerWorkDoneProgressCreateRequest rId $ J.WorkDoneProgressCreateParams progId + -- Send initial notification - liftIO $ sf $ NotProgressStart $ fmServerProgressStartNotification $ - J.ProgressStartParams progId title (Just cancellable') - Nothing initialPercentage + liftIO $ sf $ NotWorkDoneProgressBegin $ fmServerWorkDoneProgressBeginNotification $ + J.ProgressParams progId $ + J.WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage aid <- async $ f (updater progId sf) storeProgress progId aid res <- wait aid -- Send done notification - liftIO $ sf $ NotProgressDone $ fmServerProgressDoneNotification $ - J.ProgressDoneParams progId + liftIO $ sf $ NotWorkDoneProgressEnd $ fmServerWorkDoneProgressEndNotification $ + J.ProgressParams progId $ + J.WorkDoneProgressEndParams Nothing + -- Delete the progress cancellation from the map + -- If we don't do this then it's easy to leak things as the map contains any IO action. + deleteProgress progId + return res | otherwise = f (const $ return ()) where updater progId sf (Progress percentage msg) = - sf $ NotProgressReport $ fmServerProgressReportNotification $ - J.ProgressReportParams progId msg percentage + sf $ NotWorkDoneProgressReport $ fmServerWorkDoneProgressReportNotification $ + J.ProgressParams progId $ + J.WorkDoneProgressReportParams Nothing msg percentage withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a withProgress' = withProgressBase False @@ -825,6 +844,10 @@ static (Just d) _ = Just d static _ (Just _) = Just (J.GotoOptionsStatic True) static _ Nothing = Nothing + + static' (Just d) (Just _) = Just d + static' _ (Just _) = Just (J.CodeActionOptionsStatic True) + static' _ _ = Nothing sync = case textDocumentSync o of Just x -> Just (J.TDSOptions x) @@ -850,7 +873,7 @@ , J._documentHighlightProvider = supported (documentHighlightHandler h) , J._documentSymbolProvider = supported (documentSymbolHandler h) , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) - , J._codeActionProvider = codeActionProvider o + , J._codeActionProvider = static' (codeActionProvider o) (codeActionHandler h) , J._codeLensProvider = codeLensProvider o , J._documentFormattingProvider = supported (documentFormattingHandler h) , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) @@ -870,8 +893,8 @@ sendResponse tvarCtx $ RspInitialize res -progressCancelHandler :: TVar (LanguageContextData config) -> J.ProgressCancelNotification -> IO () -progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.ProgressCancelParams tid)) = do +progressCancelHandler :: TVar (LanguageContextData config) -> J.WorkDoneProgressCancelNotification -> IO () +progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do mact <- Map.lookup tid . progressCancel . resProgressData <$> readTVarIO tvarCtx case mact of Nothing -> return () diff --git a/src/Language/Haskell/LSP/Messages.hs b/src/Language/Haskell/LSP/Messages.hs --- a/src/Language/Haskell/LSP/Messages.hs +++ b/src/Language/Haskell/LSP/Messages.hs @@ -61,7 +61,7 @@ | NotDidSaveTextDocument DidSaveTextDocumentNotification | NotDidChangeWatchedFiles DidChangeWatchedFilesNotification | NotDidChangeWorkspaceFolders DidChangeWorkspaceFoldersNotification - | NotProgressCancel ProgressCancelNotification + | NotWorkDoneProgressCancel WorkDoneProgressCancelNotification -- It is common for language servers to add custom message types so these -- three constructors can be used to handle custom request, response or notification @@ -76,6 +76,7 @@ | ReqUnregisterCapability UnregisterCapabilityRequest | ReqApplyWorkspaceEdit ApplyWorkspaceEditRequest | ReqShowMessage ShowMessageRequest + | ReqWorkDoneProgressCreate WorkDoneProgressCreateRequest -- Responses | RspInitialize InitializeResponse | RspShutdown ShutdownResponse @@ -109,9 +110,9 @@ | NotPublishDiagnostics PublishDiagnosticsNotification | NotLogMessage LogMessageNotification | NotShowMessage ShowMessageNotification - | NotProgressStart ProgressStartNotification - | NotProgressReport ProgressReportNotification - | NotProgressDone ProgressDoneNotification + | NotWorkDoneProgressBegin WorkDoneProgressBeginNotification + | NotWorkDoneProgressReport WorkDoneProgressReportNotification + | NotWorkDoneProgressEnd WorkDoneProgressEndNotification | NotTelemetry TelemetryNotification -- A cancel request notification is duplex! | NotCancelRequestFromServer CancelNotificationServer diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs --- a/test/JsonSpec.hs +++ b/test/JsonSpec.hs @@ -64,11 +64,18 @@ instance Arbitrary a => Arbitrary (ResponseMessage a) where arbitrary = - ResponseMessage - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + oneof + [ ResponseMessage + <$> arbitrary + <*> arbitrary + <*> (Just <$> arbitrary) + <*> pure Nothing + , ResponseMessage + <$> arbitrary + <*> arbitrary + <*> pure Nothing + <*> (Just <$> arbitrary) + ] instance Arbitrary LspIdRsp where arbitrary = oneof [IdRspInt <$> arbitrary, IdRspString <$> arbitrary, pure IdRspNull]