{-# LANGUAGE LambdaCase #-}

module Language.LSP.Server.Progress (
  withProgress,
  withIndefiniteProgress,
  ProgressAmount (..),
  ProgressCancellable (..),
  ProgressCancelledException,
) where

import Control.Concurrent.Async
import Control.Concurrent.Extra as C
import Control.Concurrent.STM
import Control.Exception qualified as E
import Control.Lens hiding (Empty)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Data.Aeson qualified as J
import Data.Foldable
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Text (Text)
import Language.LSP.Protocol.Lens qualified as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Types qualified as L
import Language.LSP.Server.Core
import UnliftIO qualified as U
import UnliftIO.Exception qualified as UE

{- | A package indicating the percentage of progress complete and a
 an optional message to go with it during a 'withProgress'

 @since 0.10.0.0
-}
data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text)

{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session

 @since 0.11.0.0
-}
data ProgressCancelledException = ProgressCancelledException
  deriving (Int -> ProgressCancelledException -> ShowS
[ProgressCancelledException] -> ShowS
ProgressCancelledException -> String
(Int -> ProgressCancelledException -> ShowS)
-> (ProgressCancelledException -> String)
-> ([ProgressCancelledException] -> ShowS)
-> Show ProgressCancelledException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressCancelledException -> ShowS
showsPrec :: Int -> ProgressCancelledException -> ShowS
$cshow :: ProgressCancelledException -> String
show :: ProgressCancelledException -> String
$cshowList :: [ProgressCancelledException] -> ShowS
showList :: [ProgressCancelledException] -> ShowS
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

-- Get a new id for the progress session and make a new one
getNewProgressId :: MonadLsp config m => m ProgressToken
getNewProgressId :: forall config (m :: * -> *). MonadLsp config m => m ProgressToken
getNewProgressId = do
  (LanguageContextState config -> TVar Int32)
-> (Int32 -> (ProgressToken, Int32)) -> m ProgressToken
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState (ProgressData -> TVar Int32
progressNextId (ProgressData -> TVar Int32)
-> (LanguageContextState config -> ProgressData)
-> LanguageContextState config
-> TVar Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextState config -> ProgressData
forall config. LanguageContextState config -> ProgressData
resProgressData) ((Int32 -> (ProgressToken, Int32)) -> m ProgressToken)
-> (Int32 -> (ProgressToken, Int32)) -> m ProgressToken
forall a b. (a -> b) -> a -> b
$ \Int32
cur ->
    let !next :: Int32
next = Int32
cur Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1
     in ((Int32 |? Text) -> ProgressToken
L.ProgressToken ((Int32 |? Text) -> ProgressToken)
-> (Int32 |? Text) -> ProgressToken
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 |? Text
forall a b. a -> a |? b
L.InL Int32
cur, Int32
next)
{-# INLINE getNewProgressId #-}

withProgressBase ::
  forall c m a.
  MonadLsp c m =>
  Bool ->
  Text ->
  Maybe ProgressToken ->
  ProgressCancellable ->
  ((ProgressAmount -> m ()) -> m a) ->
  m a
withProgressBase :: forall c (m :: * -> *) a.
MonadLsp c m =>
Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgressBase Bool
indefinite Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (ProgressAmount -> m ()) -> m a
f = do
  let initialProgress :: ProgressAmount
initialProgress = Maybe UInt -> Maybe Text -> ProgressAmount
ProgressAmount (if Bool
indefinite then Maybe UInt
forall a. Maybe a
Nothing else UInt -> Maybe UInt
forall a. a -> Maybe a
Just UInt
0) Maybe Text
forall a. Maybe a
Nothing
  LanguageContextEnv{resProgressStartDelay :: forall config. LanguageContextEnv config -> Int
resProgressStartDelay = Int
startDelay, resProgressUpdateDelay :: forall config. LanguageContextEnv config -> Int
resProgressUpdateDelay = Int
updateDelay} <- m (LanguageContextEnv c)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv

  TMVar ProgressToken
tokenVar <- IO (TMVar ProgressToken) -> m (TMVar ProgressToken)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMVar ProgressToken)
forall a. IO (TMVar a)
newEmptyTMVarIO
  TMVar ProgressAmount
reportVar <- IO (TMVar ProgressAmount) -> m (TMVar ProgressAmount)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar ProgressAmount) -> m (TMVar ProgressAmount))
-> IO (TMVar ProgressAmount) -> m (TMVar ProgressAmount)
forall a b. (a -> b) -> a -> b
$ ProgressAmount -> IO (TMVar ProgressAmount)
forall a. a -> IO (TMVar a)
newTMVarIO ProgressAmount
initialProgress
  MVar ()
endBarrier <- IO (MVar ()) -> m (MVar ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  let
    updater :: ProgressAmount -> m ()
    updater :: ProgressAmount -> m ()
updater ProgressAmount
pa = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- I don't know of a way to do this with a normal MVar!
      -- That is: put something into it regardless of whether it is full or empty
      Maybe ProgressAmount
_ <- TMVar ProgressAmount -> STM (Maybe ProgressAmount)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar ProgressAmount
reportVar
      TMVar ProgressAmount -> ProgressAmount -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ProgressAmount
reportVar ProgressAmount
pa

    progressEnded :: IO ()
    progressEnded :: IO ()
progressEnded = MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
endBarrier

    endProgress :: IO ()
    endProgress :: IO ()
endProgress = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
endBarrier ()

    -- Once we have a 'ProgressToken', store it in the variable and also register the cancellation
    -- handler.
    registerToken :: ProgressToken -> m ()
    registerToken :: ProgressToken -> m ()
registerToken ProgressToken
t = do
      TVar (Map ProgressToken (IO ()))
handlers <- m (TVar (Map ProgressToken (IO ())))
getProgressCancellationHandlers
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TMVar ProgressToken -> ProgressToken -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ProgressToken
tokenVar ProgressToken
t
        TVar (Map ProgressToken (IO ()))
-> (Map ProgressToken (IO ()) -> Map ProgressToken (IO ()))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map ProgressToken (IO ()))
handlers (ProgressToken
-> IO () -> Map ProgressToken (IO ()) -> Map ProgressToken (IO ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ProgressToken
t IO ()
endProgress)

    -- Deregister our 'ProgressToken', specifically its cancellation handler. It is important
    -- to do this reliably or else we will leak handlers.
    unregisterToken :: m ()
    unregisterToken :: m ()
unregisterToken = do
      TVar (Map ProgressToken (IO ()))
handlers <- m (TVar (Map ProgressToken (IO ())))
getProgressCancellationHandlers
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe ProgressToken
mt <- TMVar ProgressToken -> STM (Maybe ProgressToken)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar ProgressToken
tokenVar
        Maybe ProgressToken -> (ProgressToken -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ProgressToken
mt ((ProgressToken -> STM ()) -> STM ())
-> (ProgressToken -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ProgressToken
t -> TVar (Map ProgressToken (IO ()))
-> (Map ProgressToken (IO ()) -> Map ProgressToken (IO ()))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map ProgressToken (IO ()))
handlers (ProgressToken
-> Map ProgressToken (IO ()) -> Map ProgressToken (IO ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ProgressToken
t)

    -- Find and register our 'ProgressToken', asking the client for it if necessary.
    -- Note that this computation may terminate before we get the token, we need to wait
    -- for the token var to be filled if we want to use it.
    createToken :: m ()
    createToken :: m ()
createToken = do
      -- See Note [Delayed progress reporting]
      -- This delays the creation of the token as well as the 'begin' message. Creating
      -- the token shouldn't result in any visible action on the client side since
      -- the title/initial percentage aren't given until the 'begin' mesage. However,
      -- it's neater not to create tokens that we won't use, and clients may find it
      -- easier to clean them up if they receive begin/end reports for them.
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
startDelay
      case Maybe ProgressToken
clientToken of
        -- See Note [Client- versus server-initiated progress]
        -- Client-initiated progress
        Just ProgressToken
t -> ProgressToken -> m ()
registerToken ProgressToken
t
        -- Try server-initiated progress
        Maybe ProgressToken
Nothing -> do
          ProgressToken
t <- m ProgressToken
forall config (m :: * -> *). MonadLsp config m => m ProgressToken
getNewProgressId
          ClientCapabilities
clientCaps <- m ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities

          -- If we don't have a progress token from the client and
          -- the client doesn't support server-initiated progress then
          -- there's nothing to do: we can't report progress.
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientCapabilities -> Bool
clientSupportsServerInitiatedProgress ClientCapabilities
clientCaps)
            (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
            (m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
 -> m ())
-> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
-> m ()
forall a b. (a -> b) -> a -> b
$
            -- Server-initiated progress
            -- See Note [Client- versus server-initiated progress]
            SServerMethod @'Request 'Method_WindowWorkDoneProgressCreate
-> MessageParams
     @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate
-> (Either
      (TResponseError
         @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
      (MessageResult
         @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate)
    -> m ())
-> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod @'Request m
-> MessageParams @'ServerToClient @'Request m
-> (Either
      (TResponseError @'ServerToClient m)
      (MessageResult @'ServerToClient @'Request m)
    -> f ())
-> f (LspId @'ServerToClient m)
sendRequest
              SServerMethod @'Request 'Method_WindowWorkDoneProgressCreate
SMethod_WindowWorkDoneProgressCreate
              (ProgressToken -> WorkDoneProgressCreateParams
WorkDoneProgressCreateParams ProgressToken
t)
            ((Either
    (TResponseError
       @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
    (MessageResult
       @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate)
  -> m ())
 -> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate))
-> (Either
      (TResponseError
         @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
      (MessageResult
         @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate)
    -> m ())
-> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
forall a b. (a -> b) -> a -> b
$ \case
              -- Successfully registered the token, we can now use it.
              -- So we go ahead and start. We do this as soon as we get the
              -- token back so the client gets feedback ASAP
              Right MessageResult
  @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate
_ -> ProgressToken -> m ()
registerToken ProgressToken
t
              -- The client sent us an error, we can't use the token.
              Left TResponseError
  @'ServerToClient 'Method_WindowWorkDoneProgressCreate
_err -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- Actually send the progress reports.
    sendReports :: m ()
    sendReports :: m ()
sendReports = do
      ProgressToken
t <- IO ProgressToken -> m ProgressToken
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProgressToken -> m ProgressToken)
-> IO ProgressToken -> m ProgressToken
forall a b. (a -> b) -> a -> b
$ STM ProgressToken -> IO ProgressToken
forall a. STM a -> IO a
atomically (STM ProgressToken -> IO ProgressToken)
-> STM ProgressToken -> IO ProgressToken
forall a b. (a -> b) -> a -> b
$ TMVar ProgressToken -> STM ProgressToken
forall a. TMVar a -> STM a
readTMVar TMVar ProgressToken
tokenVar
      ProgressToken -> m ()
begin ProgressToken
t
      -- Once we are sending updates, if we get interrupted we should send
      -- the end notification
      ProgressToken -> m ()
forall {b}. ProgressToken -> m b
update ProgressToken
t m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UE.finally` ProgressToken -> m ()
end ProgressToken
t
     where
      cancellable' :: Maybe Bool
cancellable' = case ProgressCancellable
cancellable of
        ProgressCancellable
Cancellable -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        ProgressCancellable
NotCancellable -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      begin :: ProgressToken -> m ()
begin ProgressToken
t = do
        (ProgressAmount Maybe UInt
pct Maybe Text
msg) <- IO ProgressAmount -> m ProgressAmount
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProgressAmount -> m ProgressAmount)
-> IO ProgressAmount -> m ProgressAmount
forall a b. (a -> b) -> a -> b
$ STM ProgressAmount -> IO ProgressAmount
forall a. STM a -> IO a
atomically (STM ProgressAmount -> IO ProgressAmount)
-> STM ProgressAmount -> IO ProgressAmount
forall a b. (a -> b) -> a -> b
$ TMVar ProgressAmount -> STM ProgressAmount
forall a. TMVar a -> STM a
takeTMVar TMVar ProgressAmount
reportVar
        ProgressToken -> WorkDoneProgressBegin -> m ()
forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
t (WorkDoneProgressBegin -> m ()) -> WorkDoneProgressBegin -> m ()
forall a b. (a -> b) -> a -> b
$ AString "begin"
-> Text
-> Maybe Bool
-> Maybe Text
-> Maybe UInt
-> WorkDoneProgressBegin
WorkDoneProgressBegin AString "begin"
forall (s :: Symbol). KnownSymbol s => AString s
L.AString Text
title Maybe Bool
cancellable' Maybe Text
msg Maybe UInt
pct
      update :: ProgressToken -> m b
update ProgressToken
t =
        m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ do
          -- See Note [Delayed progress reporting]
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
updateDelay
          (ProgressAmount Maybe UInt
pct Maybe Text
msg) <- IO ProgressAmount -> m ProgressAmount
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProgressAmount -> m ProgressAmount)
-> IO ProgressAmount -> m ProgressAmount
forall a b. (a -> b) -> a -> b
$ STM ProgressAmount -> IO ProgressAmount
forall a. STM a -> IO a
atomically (STM ProgressAmount -> IO ProgressAmount)
-> STM ProgressAmount -> IO ProgressAmount
forall a b. (a -> b) -> a -> b
$ TMVar ProgressAmount -> STM ProgressAmount
forall a. TMVar a -> STM a
takeTMVar TMVar ProgressAmount
reportVar
          ProgressToken -> WorkDoneProgressReport -> m ()
forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
t (WorkDoneProgressReport -> m ()) -> WorkDoneProgressReport -> m ()
forall a b. (a -> b) -> a -> b
$ AString "report"
-> Maybe Bool -> Maybe Text -> Maybe UInt -> WorkDoneProgressReport
WorkDoneProgressReport AString "report"
forall (s :: Symbol). KnownSymbol s => AString s
L.AString Maybe Bool
forall a. Maybe a
Nothing Maybe Text
msg Maybe UInt
pct
      end :: ProgressToken -> m ()
end ProgressToken
t = ProgressToken -> WorkDoneProgressEnd -> m ()
forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
t (AString "end" -> Maybe Text -> WorkDoneProgressEnd
WorkDoneProgressEnd AString "end"
forall (s :: Symbol). KnownSymbol s => AString s
L.AString Maybe Text
forall a. Maybe a
Nothing)

    -- Create the token and then start sending reports; all of which races with the check for the
    -- progress having ended. In all cases, make sure to unregister the token at the end.
    progressThreads :: m ()
    progressThreads :: m ()
progressThreads =
      ((m ()
createToken m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
sendReports) m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UE.finally` m ()
unregisterToken) m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
`U.race_` IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
progressEnded

  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInBase -> do
    IO a -> (Async a -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (m a -> IO a
forall a. m a -> IO a
runInBase (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ (ProgressAmount -> m ()) -> m a
f ProgressAmount -> m ()
updater) ((Async a -> IO a) -> IO a) -> (Async a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async a
mainAct ->
      -- If the progress gets cancelled then we need to get cancelled too
      IO () -> (Async () -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (m () -> IO ()
forall a. m a -> IO a
runInBase m ()
progressThreads) ((Async () -> IO a) -> IO a) -> (Async () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async ()
pthreads -> do
        Either a ()
r <- Async a -> Async () -> IO (Either a ())
forall a b. Async a -> Async b -> IO (Either a b)
waitEither Async a
mainAct Async ()
pthreads
        -- TODO: is this weird? I can't see how else to gracefully use the ending barrier
        -- as a guard to cancel the other async
        case Either a ()
r of
          Left a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
          Right ()
_ -> Async a -> ProgressCancelledException -> IO ()
forall e a. Exception e => Async a -> e -> IO ()
cancelWith Async a
mainAct ProgressCancelledException
ProgressCancelledException IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async a -> IO a
forall a. Async a -> IO a
wait Async a
mainAct
 where
  sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m ()
  sendProgressReport :: forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
token r
report = SServerMethod @'Notification ('Method_Progress @'ServerToClient)
-> MessageParams
     @'ServerToClient @'Notification ('Method_Progress @'ServerToClient)
-> m ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod @'Notification m
-> MessageParams @'ServerToClient @'Notification m -> f ()
sendNotification SServerMethod @'Notification ('Method_Progress @'ServerToClient)
forall {f :: MessageDirection}.
SMethod @f @'Notification ('Method_Progress @f)
SMethod_Progress (MessageParams
   @'ServerToClient @'Notification ('Method_Progress @'ServerToClient)
 -> m ())
-> MessageParams
     @'ServerToClient @'Notification ('Method_Progress @'ServerToClient)
-> m ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
ProgressParams ProgressToken
token (Value -> ProgressParams) -> Value -> ProgressParams
forall a b. (a -> b) -> a -> b
$ r -> Value
forall a. ToJSON a => a -> Value
J.toJSON r
report

  getProgressCancellationHandlers :: m (TVar (Map.Map ProgressToken (IO ())))
  getProgressCancellationHandlers :: m (TVar (Map ProgressToken (IO ())))
getProgressCancellationHandlers = (LanguageContextState c -> TVar (Map ProgressToken (IO ())))
-> m (TVar (Map ProgressToken (IO ())))
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m (TVar a)
getStateVar (ProgressData -> TVar (Map ProgressToken (IO ()))
progressCancel (ProgressData -> TVar (Map ProgressToken (IO ())))
-> (LanguageContextState c -> ProgressData)
-> LanguageContextState c
-> TVar (Map ProgressToken (IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextState c -> ProgressData
forall config. LanguageContextState config -> ProgressData
resProgressData)

clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool
clientSupportsServerInitiatedProgress :: ClientCapabilities -> Bool
clientSupportsServerInitiatedProgress ClientCapabilities
caps = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ClientCapabilities
caps ClientCapabilities
-> Getting (First Bool) ClientCapabilities Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe WindowClientCapabilities
 -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
-> ClientCapabilities -> Const @(*) (First Bool) ClientCapabilities
forall s a. HasWindow s a => Lens' s a
Lens' ClientCapabilities (Maybe WindowClientCapabilities)
L.window ((Maybe WindowClientCapabilities
  -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
 -> ClientCapabilities
 -> Const @(*) (First Bool) ClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> Maybe WindowClientCapabilities
    -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
-> Getting (First Bool) ClientCapabilities Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowClientCapabilities
 -> Const @(*) (First Bool) WindowClientCapabilities)
-> Maybe WindowClientCapabilities
-> Const @(*) (First Bool) (Maybe WindowClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((WindowClientCapabilities
  -> Const @(*) (First Bool) WindowClientCapabilities)
 -> Maybe WindowClientCapabilities
 -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> WindowClientCapabilities
    -> Const @(*) (First Bool) WindowClientCapabilities)
-> (Bool -> Const @(*) (First Bool) Bool)
-> Maybe WindowClientCapabilities
-> Const @(*) (First Bool) (Maybe WindowClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> WindowClientCapabilities
-> Const @(*) (First Bool) WindowClientCapabilities
forall s a. HasWorkDoneProgress s a => Lens' s a
Lens' WindowClientCapabilities (Maybe Bool)
L.workDoneProgress ((Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
 -> WindowClientCapabilities
 -> Const @(*) (First Bool) WindowClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> (Bool -> Const @(*) (First Bool) Bool)
-> WindowClientCapabilities
-> Const @(*) (First Bool) WindowClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const @(*) (First Bool) Bool)
-> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just
{-# INLINE clientSupportsServerInitiatedProgress #-}

{- |
Wrapper for reporting progress to the client during a long running task.
-}
withProgress ::
  MonadLsp c m =>
  -- | The title of the progress operation
  Text ->
  -- | The progress token provided by the client in the method params, if any
  Maybe ProgressToken ->
  -- | Whether or not this operation is cancellable. If true, the user will be
  -- shown a button to allow cancellation. Note that requests can still be cancelled
  -- even if this is not set.
  ProgressCancellable ->
  -- | An update function to pass progress updates to
  ((ProgressAmount -> m ()) -> m a) ->
  m a
withProgress :: forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgress Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (ProgressAmount -> m ()) -> m a
f = Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
forall c (m :: * -> *) a.
MonadLsp c m =>
Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgressBase Bool
False Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (ProgressAmount -> m ()) -> m a
f

{- |
Same as 'withProgress', but for processes that do not report the precentage complete.
-}
withIndefiniteProgress ::
  MonadLsp c m =>
  -- | The title of the progress operation
  Text ->
  -- | The progress token provided by the client in the method params, if any
  Maybe ProgressToken ->
  -- | Whether or not this operation is cancellable. If true, the user will be
  -- shown a button to allow cancellation. Note that requests can still be cancelled
  -- even if this is not set.
  ProgressCancellable ->
  -- | An update function to pass progress updates to
  ((Text -> m ()) -> m a) ->
  m a
withIndefiniteProgress :: forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> m ()) -> m a)
-> m a
withIndefiniteProgress Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (Text -> m ()) -> m a
f =
  Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
forall c (m :: * -> *) a.
MonadLsp c m =>
Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgressBase Bool
True Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (\ProgressAmount -> m ()
update -> (Text -> m ()) -> m a
f (\Text
msg -> ProgressAmount -> m ()
update (Maybe UInt -> Maybe Text -> ProgressAmount
ProgressAmount Maybe UInt
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg))))