haskell-lsp 0.9.0.0 → 0.10.0.0

raw patch · 5 files changed

+94/−6 lines, 5 filesdep ~haskell-lsp-typesnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-lsp-types

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• haskell-lsp.cabal +3/−2
• src/Language/Haskell/LSP/Core.hs +80/−2
• src/Language/Haskell/LSP/Messages.hs +4/−0
• test/CapabilitiesSpec.hs +2/−2

@@ -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.

@@ -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 

@@ -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 

@@ -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

@@ -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