diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for haskell-lsp +## 0.11.0.0 -- 2019-04-28 + +* Add support for cancellable requests within `withProgress` and + `withIndefiniteProgress` +* Align `withProgress` and `withIndefiniteProgress` types to be in `IO` + like the rest of the library. (Look at using `monad-control` and + `unliftio` if you need to use them with a Monad transformer stack) + ## 0.10.0.0 -- 2019-04-22 * Add `withProgress` and `withIndefiniteProgress` functions for sending diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -238,7 +238,7 @@ let ht = Just $ J.Hover ms (Just range) - ms = J.HoverContentsMS $ J.List [J.CodeString $ J.LanguageString "lsp-hello" "TYPE INFO" ] + ms = J.HoverContents $ J.markedUpContent "lsp-hello" "TYPE INFO" range = J.Range pos pos reactorSend $ RspHover $ Core.makeResponseMessage req ht 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.10.0.0 +version: 0.11.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -36,6 +36,7 @@ -- other-extensions: ghc-options: -Wall build-depends: base >=4.9 && <4.13 + , async , aeson >=1.0.0.0 , bytestring , containers @@ -44,7 +45,7 @@ , filepath , hslogger , hashable - , haskell-lsp-types >= 0.10.0 + , haskell-lsp-types == 0.11.* , 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 @@ -12,6 +12,8 @@ , InitializeCallback , LspFuncs(..) , Progress(..) + , ProgressCancellable(..) + , ProgressCancelledException , SendFunc , Handlers(..) , Options(..) @@ -26,6 +28,7 @@ ) where import Control.Concurrent.STM +import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class @@ -76,15 +79,19 @@ , resOptions :: !Options , resSendResponse :: !SendFunc , resVFS :: !VFS + , reverseMap :: !(Map.Map FilePath FilePath) , resDiagnostics :: !DiagnosticStore , resConfig :: !(Maybe a) , resLspId :: !(TVar Int) , resLspFuncs :: LspFuncs a -- NOTE: Cannot be strict, lazy initialization , resCaptureFile :: !(Maybe FilePath) , resWorkspaceFolders :: ![J.WorkspaceFolder] - , resNextProgressId :: !Int + , resProgressData :: !ProgressData } +data ProgressData = ProgressData { progressNextId :: !Int + , progressCancel :: !(Map.Map Text (IO ())) } + -- --------------------------------------------------------------------- -- | Language Server Protocol options supported by the given language server. @@ -123,8 +130,23 @@ -- | A package indicating the perecentage of progress complete and a -- an optional message to go with it during a 'withProgress' +-- +-- @since 0.10.0.0 data Progress = Progress (Maybe Double) (Maybe Text) +-- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session +-- +-- @since 0.11.0.0 +data ProgressCancelledException = ProgressCancelledException + deriving Show +instance E.Exception ProgressCancelledException + +-- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress' +-- session +-- +-- @since 0.11.0.0 +data ProgressCancellable = Cancellable | NotCancellable + -- | Returned to the server on startup, providing ways to interact with the client. data LspFuncs c = LspFuncs @@ -139,19 +161,24 @@ , getNextReqId :: !(IO J.LspId) , rootPath :: !(Maybe FilePath) , getWorkspaceFolders :: !(IO (Maybe [J.WorkspaceFolder])) - , withProgress :: !(forall m a. MonadIO m => Text -> ((Progress -> m ()) -> m a) -> m a) + , withProgress :: !(forall a . Text -> ProgressCancellable + -> ((Progress -> IO ()) -> IO a) -> IO a) -- ^ Wrapper for reporting progress to the client during a long running -- task. - -- 'withProgress' @title f@ starts a new progress reporting session, and - -- finishes it once f is completed. + -- 'withProgress' @title cancellable f@ starts a new progress reporting + -- session, and finishes it once f is completed. -- f is provided with an update function that allows it to report on -- the progress during the session. - -- + -- If @cancellable@ is 'Cancellable', @f@ will be thrown a + -- 'ProgressCancelledException' if the user cancels the action in + -- progress. + -- -- @since 0.10.0.0 - , withIndefiniteProgress :: !(forall m a. MonadIO m => Text -> m a -> m a) - -- ^ Same as 'withProgress' but for processes that do not report the - -- precentage complete - -- + , withIndefiniteProgress :: !(forall a . Text -> ProgressCancellable + -> IO a -> IO a) + -- ^ Same as 'withProgress', but for processes that do not report the + -- precentage complete. + -- -- @since 0.10.0.0 } @@ -306,7 +333,8 @@ handlerMap _ h J.TextDocumentDocumentLink = hh nop ReqDocumentLink $ documentLinkHandler h handlerMap _ h J.DocumentLinkResolve = hh nop ReqDocumentLinkResolve $ documentLinkResolveHandler h handlerMap _ h J.TextDocumentRename = hh nop ReqRename $ renameHandler h -handlerMap _ h J.TextDocumentFoldingRanges = hh nop ReqFoldingRange $ foldingRangeHandler h +handlerMap _ h J.TextDocumentFoldingRange = hh nop ReqFoldingRange $ foldingRangeHandler h +handlerMap _ _ J.WindowProgressCancel = helper progressCancelHandler handlerMap _ _ (J.Misc x) = helper f where f :: TVar (LanguageContextData c) -> J.Value -> IO () f tvarDat n = do @@ -428,8 +456,12 @@ -- defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> Maybe FilePath -> LanguageContextData c defaultLanguageContextData h o lf tv sf cf = - LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty Nothing tv lf cf mempty 0 + LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty mempty + Nothing tv lf cf mempty defaultProgressData +defaultProgressData :: ProgressData +defaultProgressData = ProgressData 0 Map.empty + -- --------------------------------------------------------------------- handleMessage :: (Show c) => InitializeCallback c @@ -597,56 +629,62 @@ let (C.ClientCapabilities _ _ wc _) = params ^. J.capabilities (C.WindowClientCapabilities mProgress) <- wc mProgress - + + storeProgress :: Text -> 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' }}) + -- Get a new id for the progress session and make a new one - getNewProgressId :: MonadIO m => m Text + getNewProgressId :: IO Text getNewProgressId = fmap (T.pack . show) $ liftIO $ atomically $ do - x <- resNextProgressId <$> readTVar tvarCtx - modifyTVar tvarCtx (\ctx -> ctx { resNextProgressId = x + 1}) + pd <- resProgressData <$> readTVar tvarCtx + let x = progressNextId pd + modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressNextId = x + 1 }}) return x - - withProgress' :: (forall m. MonadIO m => Text -> ((Progress -> m ()) -> m a) -> m a) - withProgress' title f + + withProgressBase :: Bool -> (Text -> ProgressCancellable + -> ((Progress -> IO ()) -> IO a) -> IO a) + withProgressBase indefinite title cancellable f | clientSupportsProgress = do sf <- liftIO $ resSendResponse <$> readTVarIO tvarCtx progId <- getNewProgressId + let initialPercentage + | indefinite = Nothing + | otherwise = Just 0 + cancellable' = case cancellable of + Cancellable -> True + NotCancellable -> False + -- Send initial notification liftIO $ sf $ NotProgressStart $ fmServerProgressStartNotification $ - J.ProgressStartParams progId title (Just False) Nothing (Just 0) + J.ProgressStartParams progId title (Just cancellable') + Nothing initialPercentage - res <- f (updater progId sf) + aid <- async $ f (updater progId sf) + storeProgress progId aid + res <- wait aid -- Send done notification liftIO $ sf $ NotProgressDone $ fmServerProgressDoneNotification $ J.ProgressDoneParams progId - + return res | otherwise = f (const $ return ()) - where updater progId sf (Progress percentage msg) = liftIO $ + where updater progId sf (Progress percentage msg) = sf $ NotProgressReport $ fmServerProgressReportNotification $ J.ProgressReportParams progId msg percentage - - withIndefiniteProgress' :: (forall m. MonadIO m => Text -> m a -> m a) - withIndefiniteProgress' title f - | clientSupportsProgress = do - sf <- liftIO $ resSendResponse <$> readTVarIO tvarCtx - progId <- getNewProgressId - - -- Send initial notification - liftIO $ sf $ NotProgressStart $ fmServerProgressStartNotification $ - J.ProgressStartParams progId title (Just False) Nothing Nothing - - res <- f + withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a + withProgress' = withProgressBase False - -- Send done notification - liftIO $ sf $ NotProgressDone $ fmServerProgressDoneNotification $ - J.ProgressDoneParams progId - - return res - | otherwise = f + withIndefiniteProgress' :: Text -> ProgressCancellable -> IO a -> IO a + withIndefiniteProgress' title cancellable f = + withProgressBase True title cancellable (const f) -- Launch the given process once the project root directory has been set let lspFuncs = LspFuncs (getCapabilities params) @@ -727,6 +765,14 @@ res = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing sendResponse tvarCtx $ RspInitialize res + +progressCancelHandler :: TVar (LanguageContextData c) -> J.ProgressCancelNotification -> IO () +progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.ProgressCancelParams tid)) = do + mact <- Map.lookup tid . progressCancel . resProgressData <$> readTVarIO tvarCtx + case mact of + Nothing -> return () + Just cancelAction -> cancelAction + -- | -- 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 @@ -60,6 +60,7 @@ | NotDidSaveTextDocument DidSaveTextDocumentNotification | NotDidChangeWatchedFiles DidChangeWatchedFilesNotification | NotDidChangeWorkspaceFolders DidChangeWorkspaceFoldersNotification + | NotProgressCancel ProgressCancelNotification -- Unknown (The client sends something we don't understand) | UnknownFromClientMessage Value deriving (Eq,Read,Show,Generic,ToJSON,FromJSON) @@ -106,7 +107,6 @@ | NotProgressStart ProgressStartNotification | NotProgressReport ProgressReportNotification | NotProgressDone ProgressDoneNotification - | NotProgressCancel ProgressCancelNotification | NotTelemetry TelemetryNotification -- A cancel request notification is duplex! | NotCancelRequestFromServer CancelNotificationServer