diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for haskell-lsp +## 0.10.0.0 -- 2019-04-22 + +* Add `withProgress` and `withIndefiniteProgress` functions for sending + `window/progress` notifications. + ## 0.9.0.0 * Add `MarkupContent` to `HoverResponse`, and (some) json roundtrip tests. 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.9.0.0 +version: 0.10.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -44,7 +44,7 @@ , filepath , hslogger , hashable - , haskell-lsp-types >= 0.8.3 + , haskell-lsp-types >= 0.10.0 , lens >= 4.15.2 , mtl , network-uri @@ -122,6 +122,7 @@ , stm , text , yi-rope + build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 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 @@ -11,6 +11,7 @@ , Handler , InitializeCallback , LspFuncs(..) + , Progress(..) , SendFunc , Handlers(..) , Options(..) @@ -27,6 +28,7 @@ import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad +import Control.Monad.IO.Class import Control.Lens ( (<&>), (^.) ) import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL @@ -80,6 +82,7 @@ , resLspFuncs :: LspFuncs a -- NOTE: Cannot be strict, lazy initialization , resCaptureFile :: !(Maybe FilePath) , resWorkspaceFolders :: ![J.WorkspaceFolder] + , resNextProgressId :: !Int } -- --------------------------------------------------------------------- @@ -118,6 +121,10 @@ type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send -> Maybe J.DiagnosticSource -> IO () +-- | A package indicating the perecentage of progress complete and a +-- an optional message to go with it during a 'withProgress' +data Progress = Progress (Maybe Double) (Maybe Text) + -- | Returned to the server on startup, providing ways to interact with the client. data LspFuncs c = LspFuncs @@ -132,6 +139,20 @@ , 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) + -- ^ 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. + -- f is provided with an update function that allows it to report on + -- the progress during the session. + -- + -- @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 + -- + -- @since 0.10.0.0 } -- | The function in the LSP process that is called once the 'initialize' @@ -407,7 +428,7 @@ -- 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 + LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty Nothing tv lf cf mempty 0 -- --------------------------------------------------------------------- @@ -565,13 +586,68 @@ return $ J.IdInt cid clientSupportsWfs = fromMaybe False $ do - let (C.ClientCapabilities mw _ _) = params ^. J.capabilities + let (C.ClientCapabilities mw _ _ _) = params ^. J.capabilities (C.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw mwf getWfs tvc | clientSupportsWfs = atomically $ Just . resWorkspaceFolders <$> readTVar tvc | otherwise = return Nothing + clientSupportsProgress = fromMaybe False $ do + let (C.ClientCapabilities _ _ wc _) = params ^. J.capabilities + (C.WindowClientCapabilities mProgress) <- wc + mProgress + + -- Get a new id for the progress session and make a new one + getNewProgressId :: MonadIO m => m Text + getNewProgressId = fmap (T.pack . show) $ liftIO $ atomically $ do + x <- resNextProgressId <$> readTVar tvarCtx + modifyTVar tvarCtx (\ctx -> ctx { resNextProgressId = x + 1}) + return x + + withProgress' :: (forall m. MonadIO m => Text -> ((Progress -> m ()) -> m a) -> m a) + withProgress' 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 (Just 0) + + res <- f (updater progId sf) + + -- Send done notification + liftIO $ sf $ NotProgressDone $ fmServerProgressDoneNotification $ + J.ProgressDoneParams progId + + return res + | otherwise = f (const $ return ()) + where updater progId sf (Progress percentage msg) = liftIO $ + 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 + + -- Send done notification + liftIO $ sf $ NotProgressDone $ fmServerProgressDoneNotification $ + J.ProgressDoneParams progId + + return res + | otherwise = f + -- Launch the given process once the project root directory has been set let lspFuncs = LspFuncs (getCapabilities params) (getConfig tvarCtx) @@ -582,6 +658,8 @@ (getLspId $ resLspId ctx0) rootDir (getWfs tvarCtx) + withProgress' + withIndefiniteProgress' let ctx = ctx0 { resLspFuncs = lspFuncs } atomically $ writeTVar tvarCtx ctx 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 @@ -103,6 +103,10 @@ | NotPublishDiagnostics PublishDiagnosticsNotification | NotLogMessage LogMessageNotification | NotShowMessage ShowMessageNotification + | NotProgressStart ProgressStartNotification + | NotProgressReport ProgressReportNotification + | NotProgressDone ProgressDoneNotification + | NotProgressCancel ProgressCancelNotification | NotTelemetry TelemetryNotification -- A cancel request notification is duplex! | NotCancelRequestFromServer CancelNotificationServer diff --git a/test/CapabilitiesSpec.hs b/test/CapabilitiesSpec.hs --- a/test/CapabilitiesSpec.hs +++ b/test/CapabilitiesSpec.hs @@ -6,10 +6,10 @@ spec :: Spec spec = describe "capabilities" $ do it "gives 3.10 capabilities" $ - let ClientCapabilities _ (Just tdcs) _ = capsForVersion (LSPVersion 3 10) + let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 10) Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs in mHierarchical `shouldBe` Just True it "gives pre 3.10 capabilities" $ - let ClientCapabilities _ (Just tdcs) _ = capsForVersion (LSPVersion 3 9) + let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 9) Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs in mHierarchical `shouldBe` Nothing