module Development.IDE.Core.ProgressReporting
  ( ProgressEvent(..)
  , ProgressReporting(..)
  , noProgressReporting
  , delayedProgressReporting
  -- utilities, reexported for use in Core.Shake
  , mRunLspT
  , mRunLspTCallback
  -- for tests
  , recordProgress
  , InProgressState(..)
  )
   where

import           Control.Concurrent.Async
import           Control.Concurrent.STM.Stats   (TVar, atomicallyNamed,
                                                 modifyTVar', newTVarIO,
                                                 readTVarIO)
import           Control.Concurrent.Strict
import           Control.Monad.Extra            hiding (loop)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class      (lift)
import           Data.Aeson                     (ToJSON (toJSON))
import           Data.Foldable                  (for_)
import           Data.Functor                   (($>))
import qualified Data.Text                      as T
import           Data.Unique
import           Development.IDE.GHC.Orphans    ()
import           Development.IDE.Graph          hiding (ShakeValue)
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import qualified Focus
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import qualified Language.LSP.Protocol.Types    as LSP
import qualified Language.LSP.Server            as LSP
import qualified StmContainers.Map              as STM
import           System.Time.Extra
import           UnliftIO.Exception             (bracket_)

data ProgressEvent
    = KickStarted
    | KickCompleted

data ProgressReporting  = ProgressReporting
  { ProgressReporting -> ProgressEvent -> IO ()
progressUpdate :: ProgressEvent -> IO ()
  , ProgressReporting
-> forall a. NormalizedFilePath -> Action a -> Action a
inProgress     :: forall a. NormalizedFilePath -> Action a -> Action a
  , ProgressReporting -> IO ()
progressStop   :: IO ()
  }

noProgressReporting :: IO ProgressReporting
noProgressReporting :: IO ProgressReporting
noProgressReporting = ProgressReporting -> IO ProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressReporting -> IO ProgressReporting)
-> ProgressReporting -> IO ProgressReporting
forall a b. (a -> b) -> a -> b
$ ProgressReporting
  { progressUpdate :: ProgressEvent -> IO ()
progressUpdate = IO () -> ProgressEvent -> IO ()
forall a b. a -> b -> a
const (IO () -> ProgressEvent -> IO ())
-> IO () -> ProgressEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
inProgress = (Action a -> Action a)
-> NormalizedFilePath -> Action a -> Action a
forall a b. a -> b -> a
const Action a -> Action a
forall a. a -> a
id
  , progressStop :: IO ()
progressStop   = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  }

-- | State used in 'delayedProgressReporting'
data State
    = NotStarted
    | Stopped
    | Running (Async ())

-- | State transitions used in 'delayedProgressReporting'
data Transition = Event ProgressEvent | StopProgress

updateState :: IO (Async ()) -> Transition -> State -> IO State
updateState :: IO (Async ()) -> Transition -> State -> IO State
updateState IO (Async ())
_      Transition
_                    State
Stopped     = State -> IO State
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
Stopped
updateState IO (Async ())
start (Event ProgressEvent
KickStarted)   State
NotStarted  = Async () -> State
Running (Async () -> State) -> IO (Async ()) -> IO State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Async ())
start
updateState IO (Async ())
start (Event ProgressEvent
KickStarted)   (Running Async ()
a) = Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
a IO () -> IO State -> IO State
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async () -> State
Running (Async () -> State) -> IO (Async ()) -> IO State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Async ())
start
updateState IO (Async ())
_     (Event ProgressEvent
KickCompleted) (Running Async ()
a) = Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
a IO () -> State -> IO State
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> State
NotStarted
updateState IO (Async ())
_     (Event ProgressEvent
KickCompleted) State
st          = State -> IO State
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
updateState IO (Async ())
_     Transition
StopProgress          (Running Async ()
a) = Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
a IO () -> State -> IO State
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> State
Stopped
updateState IO (Async ())
_     Transition
StopProgress          State
st          = State -> IO State
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st

-- | Data structure to track progress across the project
data InProgressState = InProgressState
    { InProgressState -> TVar Int
todoVar    :: TVar Int  -- ^ Number of files to do
    , InProgressState -> TVar Int
doneVar    :: TVar Int  -- ^ Number of files done
    , InProgressState -> Map NormalizedFilePath Int
currentVar :: STM.Map NormalizedFilePath Int
    }

newInProgress :: IO InProgressState
newInProgress :: IO InProgressState
newInProgress = TVar Int
-> TVar Int -> Map NormalizedFilePath Int -> InProgressState
InProgressState (TVar Int
 -> TVar Int -> Map NormalizedFilePath Int -> InProgressState)
-> IO (TVar Int)
-> IO (TVar Int -> Map NormalizedFilePath Int -> InProgressState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0 IO (TVar Int -> Map NormalizedFilePath Int -> InProgressState)
-> IO (TVar Int)
-> IO (Map NormalizedFilePath Int -> InProgressState)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0 IO (Map NormalizedFilePath Int -> InProgressState)
-> IO (Map NormalizedFilePath Int) -> IO InProgressState
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Map NormalizedFilePath Int)
forall key value. IO (Map key value)
STM.newIO

recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
recordProgress InProgressState{TVar Int
Map NormalizedFilePath Int
todoVar :: InProgressState -> TVar Int
doneVar :: InProgressState -> TVar Int
currentVar :: InProgressState -> Map NormalizedFilePath Int
todoVar :: TVar Int
doneVar :: TVar Int
currentVar :: Map NormalizedFilePath Int
..} NormalizedFilePath
file Int -> Int
shift = do
    (Maybe Int
prev, Int
new) <- String -> STM (Maybe Int, Int) -> IO (Maybe Int, Int)
forall a. String -> STM a -> IO a
atomicallyNamed String
"recordProgress" (STM (Maybe Int, Int) -> IO (Maybe Int, Int))
-> STM (Maybe Int, Int) -> IO (Maybe Int, Int)
forall a b. (a -> b) -> a -> b
$ Focus Int STM (Maybe Int, Int)
-> NormalizedFilePath
-> Map NormalizedFilePath Int
-> STM (Maybe Int, Int)
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus Focus Int STM (Maybe Int, Int)
alterPrevAndNew NormalizedFilePath
file Map NormalizedFilePath Int
currentVar
    String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"recordProgress2" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        case (Maybe Int
prev,Int
new) of
            (Maybe Int
Nothing,Int
0) -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) STM () -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
todoVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            (Maybe Int
Nothing,Int
_) -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
todoVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            (Just Int
0, Int
0) -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            (Just Int
0, Int
_) -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar Int -> Int
forall a. Enum a => a -> a
pred
            (Just Int
_, Int
0) -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            (Just Int
_, Int
_) -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure()
  where
    alterPrevAndNew :: Focus Int STM (Maybe Int, Int)
alterPrevAndNew = do
        Maybe Int
prev <- Focus Int STM (Maybe Int)
forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookup
        (Maybe Int -> Maybe Int) -> Focus Int STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe Int -> Maybe Int
alter
        Int
new <- Int -> Focus Int STM Int
forall (m :: * -> *) a. Monad m => a -> Focus a m a
Focus.lookupWithDefault Int
0
        (Maybe Int, Int) -> Focus Int STM (Maybe Int, Int)
forall a. a -> Focus Int STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
prev, Int
new)
    alter :: Maybe Int -> Maybe Int
alter Maybe Int
x = let x' :: Int
x' = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Int
shift Int
0) Int -> Int
shift Maybe Int
x in Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x'

-- | A 'ProgressReporting' that enqueues Begin and End notifications in a new
--   thread, with a grace period (nothing will be sent if 'KickCompleted' arrives
--   before the end of the grace period).
delayedProgressReporting
  :: Seconds  -- ^ Grace period before starting
  -> Seconds  -- ^ sampling delay
  -> Maybe (LSP.LanguageContextEnv c)
  -> ProgressReportingStyle
  -> IO ProgressReporting
delayedProgressReporting :: forall c.
Seconds
-> Seconds
-> Maybe (LanguageContextEnv c)
-> ProgressReportingStyle
-> IO ProgressReporting
delayedProgressReporting Seconds
_before Seconds
_after Maybe (LanguageContextEnv c)
Nothing ProgressReportingStyle
_optProgressStyle = IO ProgressReporting
noProgressReporting
delayedProgressReporting Seconds
before Seconds
after (Just LanguageContextEnv c
lspEnv) ProgressReportingStyle
optProgressStyle = do
    InProgressState
inProgressState <- IO InProgressState
newInProgress
    Var State
progressState <- State -> IO (Var State)
forall a. a -> IO (Var a)
newVar State
NotStarted
    let progressUpdate :: ProgressEvent -> IO ()
progressUpdate ProgressEvent
event = Transition -> IO ()
updateStateVar (Transition -> IO ()) -> Transition -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgressEvent -> Transition
Event ProgressEvent
event
        progressStop :: IO ()
progressStop   =  Transition -> IO ()
updateStateVar Transition
StopProgress
        updateStateVar :: Transition -> IO ()
updateStateVar = Var State -> (State -> IO State) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var State
progressState ((State -> IO State) -> IO ())
-> (Transition -> State -> IO State) -> Transition -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Async ()) -> Transition -> State -> IO State
updateState (InProgressState -> IO (Async ())
forall {m :: * -> *}.
MonadUnliftIO m =>
InProgressState -> m (Async ())
lspShakeProgress InProgressState
inProgressState)

        inProgress :: NormalizedFilePath -> Action c -> Action c
inProgress = InProgressState -> NormalizedFilePath -> Action c -> Action c
forall {c}.
InProgressState -> NormalizedFilePath -> Action c -> Action c
updateStateForFile InProgressState
inProgressState
    ProgressReporting -> IO ProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProgressReporting{IO ()
NormalizedFilePath -> Action a -> Action a
ProgressEvent -> IO ()
forall a. NormalizedFilePath -> Action a -> Action a
progressUpdate :: ProgressEvent -> IO ()
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
progressStop :: IO ()
progressUpdate :: ProgressEvent -> IO ()
progressStop :: IO ()
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
..}
    where
        lspShakeProgress :: InProgressState -> m (Async ())
lspShakeProgress InProgressState{TVar Int
Map NormalizedFilePath Int
todoVar :: InProgressState -> TVar Int
doneVar :: InProgressState -> TVar Int
currentVar :: InProgressState -> Map NormalizedFilePath Int
todoVar :: TVar Int
doneVar :: TVar Int
currentVar :: Map NormalizedFilePath Int
..} = do
            -- first sleep a bit, so we only show progress messages if it's going to take
            -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
            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
$ Seconds -> IO ()
sleep Seconds
before
            ProgressToken
u <- (Int32 |? Text) -> ProgressToken
ProgressToken ((Int32 |? Text) -> ProgressToken)
-> (Unique -> Int32 |? Text) -> Unique -> ProgressToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int32 |? Text
forall a b. b -> a |? b
InR (Text -> Int32 |? Text)
-> (Unique -> Text) -> Unique -> Int32 |? Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Unique -> String) -> Unique -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Unique -> Int) -> Unique -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique (Unique -> ProgressToken) -> m Unique -> m ProgressToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique -> m Unique
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
newUnique

            Barrier (Either ResponseError Null)
b <- IO (Barrier (Either ResponseError Null))
-> m (Barrier (Either ResponseError Null))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Barrier (Either ResponseError Null))
forall a. IO (Barrier a)
newBarrier
            m (LspId 'Method_WindowWorkDoneProgressCreate) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (LspId 'Method_WindowWorkDoneProgressCreate) -> m ())
-> m (LspId 'Method_WindowWorkDoneProgressCreate) -> m ()
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv c
-> LspT c m (LspId 'Method_WindowWorkDoneProgressCreate)
-> m (LspId 'Method_WindowWorkDoneProgressCreate)
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv (LspT c m (LspId 'Method_WindowWorkDoneProgressCreate)
 -> m (LspId 'Method_WindowWorkDoneProgressCreate))
-> LspT c m (LspId 'Method_WindowWorkDoneProgressCreate)
-> m (LspId 'Method_WindowWorkDoneProgressCreate)
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WindowWorkDoneProgressCreate
-> MessageParams 'Method_WindowWorkDoneProgressCreate
-> (Either
      ResponseError (MessageResult 'Method_WindowWorkDoneProgressCreate)
    -> LspT c m ())
-> LspT c m (LspId 'Method_WindowWorkDoneProgressCreate)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'Method_WindowWorkDoneProgressCreate
SMethod_WindowWorkDoneProgressCreate
                LSP.WorkDoneProgressCreateParams { $sel:_token:WorkDoneProgressCreateParams :: ProgressToken
_token = ProgressToken
u } ((Either
    ResponseError (MessageResult 'Method_WindowWorkDoneProgressCreate)
  -> LspT c m ())
 -> LspT c m (LspId 'Method_WindowWorkDoneProgressCreate))
-> (Either
      ResponseError (MessageResult 'Method_WindowWorkDoneProgressCreate)
    -> LspT c m ())
-> LspT c m (LspId 'Method_WindowWorkDoneProgressCreate)
forall a b. (a -> b) -> a -> b
$ IO () -> LspT c m ()
forall a. IO a -> LspT c m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT c m ())
-> (Either ResponseError Null -> IO ())
-> Either ResponseError Null
-> LspT c m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Barrier (Either ResponseError Null)
-> Either ResponseError Null -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier (Either ResponseError Null)
b
            IO (Async ()) -> m (Async ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> m (Async ())) -> IO (Async ()) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
                Either ResponseError Null
ready <- Barrier (Either ResponseError Null)
-> IO (Either ResponseError Null)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either ResponseError Null)
b
                LanguageContextEnv c -> LspT c IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv (LspT c IO () -> IO ()) -> LspT c IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Either ResponseError Null
-> (Null -> LspT c IO Any) -> LspT c IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either ResponseError Null
ready ((Null -> LspT c IO Any) -> LspT c IO ())
-> (Null -> LspT c IO Any) -> LspT c IO ()
forall a b. (a -> b) -> a -> b
$ LspT c IO Any -> Null -> LspT c IO Any
forall a b. a -> b -> a
const (LspT c IO Any -> Null -> LspT c IO Any)
-> LspT c IO Any -> Null -> LspT c IO Any
forall a b. (a -> b) -> a -> b
$ LspT c IO () -> LspT c IO () -> LspT c IO Any -> LspT c IO Any
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ (ProgressToken -> LspT c IO ()
forall {config} {f :: * -> *}.
MonadLsp config f =>
ProgressToken -> f ()
start ProgressToken
u) (ProgressToken -> LspT c IO ()
forall {config} {f :: * -> *}.
MonadLsp config f =>
ProgressToken -> f ()
stop ProgressToken
u) (ProgressToken -> UInt -> LspT c IO Any
forall {f :: * -> *} {config} {b}.
MonadLsp config f =>
ProgressToken -> UInt -> f b
loop ProgressToken
u UInt
0)
            where
                start :: ProgressToken -> f ()
start ProgressToken
token = SServerMethod 'Method_Progress
-> MessageParams 'Method_Progress -> f ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_Progress
forall {f :: MessageDirection}. SMethod 'Method_Progress
SMethod_Progress (MessageParams 'Method_Progress -> f ())
-> MessageParams 'Method_Progress -> f ()
forall a b. (a -> b) -> a -> b
$
                    LSP.ProgressParams
                        { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
token
                        , $sel:_value:ProgressParams :: Value
_value = WorkDoneProgressBegin -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkDoneProgressBegin -> Value) -> WorkDoneProgressBegin -> Value
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressBegin
                          { $sel:_kind:WorkDoneProgressBegin :: AString "begin"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
AString @"begin"
                          ,  $sel:_title:WorkDoneProgressBegin :: Text
_title = Text
"Processing"
                          , $sel:_cancellable:WorkDoneProgressBegin :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                          , $sel:_message:WorkDoneProgressBegin :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                          , $sel:_percentage:WorkDoneProgressBegin :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                          }
                        }
                stop :: ProgressToken -> f ()
stop ProgressToken
token = SServerMethod 'Method_Progress
-> MessageParams 'Method_Progress -> f ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_Progress
forall {f :: MessageDirection}. SMethod 'Method_Progress
SMethod_Progress
                    LSP.ProgressParams
                        { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
token
                        , $sel:_value:ProgressParams :: Value
_value = WorkDoneProgressEnd -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkDoneProgressEnd -> Value) -> WorkDoneProgressEnd -> Value
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressEnd
                          { $sel:_kind:WorkDoneProgressEnd :: AString "end"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
AString @"end"
                           , $sel:_message:WorkDoneProgressEnd :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                          }
                        }
                loop :: ProgressToken -> UInt -> f b
loop ProgressToken
_ UInt
_ | ProgressReportingStyle
optProgressStyle ProgressReportingStyle -> ProgressReportingStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressReportingStyle
NoProgress =
                    f () -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (f () -> f b) -> f () -> f b
forall a b. (a -> b) -> a -> b
$ IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
                loop ProgressToken
token UInt
prevPct = do
                    Int
done <- IO Int -> f Int
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> f Int) -> IO Int -> f Int
forall a b. (a -> b) -> a -> b
$ TVar Int -> IO Int
forall a. TVar a -> IO a
readTVarIO TVar Int
doneVar
                    Int
todo <- IO Int -> f Int
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> f Int) -> IO Int -> f Int
forall a b. (a -> b) -> a -> b
$ TVar Int -> IO Int
forall a. TVar a -> IO a
readTVarIO TVar Int
todoVar
                    IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
after
                    if Int
todo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ProgressToken -> UInt -> f b
loop ProgressToken
token UInt
0 else do
                        let
                            nextFrac :: Double
                            nextFrac :: Seconds
nextFrac = Int -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
done Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Int -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
todo
                            nextPct :: UInt
                            nextPct :: UInt
nextPct = Seconds -> UInt
forall b. Integral b => Seconds -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Seconds -> UInt) -> Seconds -> UInt
forall a b. (a -> b) -> a -> b
$ Seconds
100 Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
* Seconds
nextFrac
                        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UInt
nextPct UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
/= UInt
prevPct) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
                          SServerMethod 'Method_Progress
-> MessageParams 'Method_Progress -> f ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_Progress
forall {f :: MessageDirection}. SMethod 'Method_Progress
SMethod_Progress (MessageParams 'Method_Progress -> f ())
-> MessageParams 'Method_Progress -> f ()
forall a b. (a -> b) -> a -> b
$
                          LSP.ProgressParams
                              { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
token
                              , $sel:_value:ProgressParams :: Value
_value = case ProgressReportingStyle
optProgressStyle of
                                  ProgressReportingStyle
Explicit -> WorkDoneProgressReport -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkDoneProgressReport -> Value)
-> WorkDoneProgressReport -> Value
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressReport
                                    { $sel:_kind:WorkDoneProgressReport :: AString "report"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
AString @"report"
                                    , $sel:_cancellable:WorkDoneProgressReport :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                                    , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
done String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
todo
                                    , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                                    }
                                  ProgressReportingStyle
Percentage -> WorkDoneProgressReport -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkDoneProgressReport -> Value)
-> WorkDoneProgressReport -> Value
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressReport
                                    { $sel:_kind:WorkDoneProgressReport :: AString "report"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
AString @"report"
                                    , $sel:_cancellable:WorkDoneProgressReport :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                                    , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                                    , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = UInt -> Maybe UInt
forall a. a -> Maybe a
Just UInt
nextPct
                                    }
                                  ProgressReportingStyle
NoProgress -> String -> Value
forall a. Partial => String -> a
error String
"unreachable"
                              }
                        ProgressToken -> UInt -> f b
loop ProgressToken
token UInt
nextPct

        updateStateForFile :: InProgressState -> NormalizedFilePath -> Action c -> Action c
updateStateForFile InProgressState
inProgress NormalizedFilePath
file = IO () -> (() -> IO ()) -> (() -> Action c) -> Action c
forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket ((Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
succ) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
pred) ((() -> Action c) -> Action c)
-> (Action c -> () -> Action c) -> Action c -> Action c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action c -> () -> Action c
forall a b. a -> b -> a
const
            -- This functions are deliberately eta-expanded to avoid space leaks.
            -- Do not remove the eta-expansion without profiling a session with at
            -- least 1000 modifications.
            where
              f :: (Int -> Int) -> IO ()
f Int -> Int
shift = InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
recordProgress InProgressState
inProgress NormalizedFilePath
file Int -> Int
shift

mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()
mRunLspT :: forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT (Just LanguageContextEnv c
lspEnv) LspT c m ()
f = LanguageContextEnv c -> LspT c m () -> m ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv LspT c m ()
f
mRunLspT Maybe (LanguageContextEnv c)
Nothing LspT c m ()
_       = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

mRunLspTCallback :: Monad m
                 => Maybe (LSP.LanguageContextEnv c)
                 -> (LSP.LspT c m a -> LSP.LspT c m a)
                 -> m a
                 -> m a
mRunLspTCallback :: forall (m :: * -> *) c a.
Monad m =>
Maybe (LanguageContextEnv c)
-> (LspT c m a -> LspT c m a) -> m a -> m a
mRunLspTCallback (Just LanguageContextEnv c
lspEnv) LspT c m a -> LspT c m a
f m a
g = LanguageContextEnv c -> LspT c m a -> m a
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv (LspT c m a -> m a) -> LspT c m a -> m a
forall a b. (a -> b) -> a -> b
$ LspT c m a -> LspT c m a
f (m a -> LspT c m a
forall (m :: * -> *) a. Monad m => m a -> LspT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
g)
mRunLspTCallback Maybe (LanguageContextEnv c)
Nothing LspT c m a -> LspT c m a
_ m a
g       = m a
g