{-# LANGUAGE RankNTypes #-}
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
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class      (lift)
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 qualified Language.LSP.Server            as LSP
import           Language.LSP.Types
import qualified Language.LSP.Types             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 (m :: * -> *) a. Monad m => a -> m a
return (ProgressReporting -> IO ProgressReporting)
-> ProgressReporting -> IO ProgressReporting
forall a b. (a -> b) -> a -> b
$ ProgressReporting :: (ProgressEvent -> IO ())
-> (forall a. NormalizedFilePath -> Action a -> Action a)
-> IO ()
-> ProgressReporting
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 (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 (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 () -> Transition -> State -> IO State
updateState :: IO () -> Transition -> State -> IO State
updateState IO ()
_      Transition
_                    State
Stopped     = State -> IO State
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
Stopped
updateState IO ()
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 () -> IO (Async ())
forall a. IO a -> IO (Async a)
async IO ()
start
updateState IO ()
start (Event ProgressEvent
KickStarted)   (Running Async ()
a) = Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
a IO () -> IO State -> IO State
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 () -> IO (Async ())
forall a. IO a -> IO (Async a)
async IO ()
start
updateState IO ()
_     (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 ()
_     (Event ProgressEvent
KickCompleted) State
st          = State -> IO State
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
updateState IO ()
_     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 ()
_     Transition
StopProgress          State
st          = State -> IO State
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 (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 (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
currentVar :: Map NormalizedFilePath Int
doneVar :: TVar Int
todoVar :: TVar Int
currentVar :: InProgressState -> Map NormalizedFilePath Int
doneVar :: InProgressState -> TVar Int
todoVar :: InProgressState -> TVar 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.
(Eq key, 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 (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 (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 (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 (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 :: Seconds
-> Seconds
-> Maybe (LanguageContextEnv c)
-> ProgressReportingStyle
-> IO ProgressReporting
delayedProgressReporting Seconds
before Seconds
after Maybe (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 () -> Transition -> State -> IO State
updateState (Maybe (LanguageContextEnv c) -> LspT c IO () -> IO ()
forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT Maybe (LanguageContextEnv c)
lspEnv (LspT c IO () -> IO ()) -> LspT c IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InProgressState -> LspT c IO ()
forall config (m :: * -> *).
MonadLsp config m =>
InProgressState -> m ()
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 (m :: * -> *) a. Monad m => a -> m a
return ProgressReporting :: (ProgressEvent -> IO ())
-> (forall a. NormalizedFilePath -> Action a -> Action a)
-> IO ()
-> ProgressReporting
ProgressReporting{IO ()
ProgressEvent -> IO ()
forall a. NormalizedFilePath -> Action a -> Action a
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
progressStop :: IO ()
progressUpdate :: ProgressEvent -> IO ()
progressStop :: IO ()
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
progressUpdate :: ProgressEvent -> IO ()
..}
    where
        lspShakeProgress :: InProgressState -> m ()
lspShakeProgress InProgressState{TVar Int
Map NormalizedFilePath Int
currentVar :: Map NormalizedFilePath Int
doneVar :: TVar Int
todoVar :: TVar Int
currentVar :: InProgressState -> Map NormalizedFilePath Int
doneVar :: InProgressState -> TVar Int
todoVar :: InProgressState -> TVar 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 (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 <- Text -> ProgressToken
ProgressTextToken (Text -> ProgressToken)
-> (Unique -> Text) -> Unique -> ProgressToken
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
newUnique

            Barrier (Either ResponseError Empty)
b <- IO (Barrier (Either ResponseError Empty))
-> m (Barrier (Either ResponseError Empty))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Barrier (Either ResponseError Empty))
forall a. IO (Barrier a)
newBarrier
            m (LspId 'WindowWorkDoneProgressCreate) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (LspId 'WindowWorkDoneProgressCreate) -> m ())
-> m (LspId 'WindowWorkDoneProgressCreate) -> m ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'WindowWorkDoneProgressCreate
-> MessageParams 'WindowWorkDoneProgressCreate
-> (Either
      ResponseError (ResponseResult 'WindowWorkDoneProgressCreate)
    -> m ())
-> m (LspId 'WindowWorkDoneProgressCreate)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WindowWorkDoneProgressCreate
LSP.SWindowWorkDoneProgressCreate
                WorkDoneProgressCreateParams :: ProgressToken -> WorkDoneProgressCreateParams
LSP.WorkDoneProgressCreateParams { $sel:_token:WorkDoneProgressCreateParams :: ProgressToken
_token = ProgressToken
u } ((Either
    ResponseError (ResponseResult 'WindowWorkDoneProgressCreate)
  -> m ())
 -> m (LspId 'WindowWorkDoneProgressCreate))
-> (Either
      ResponseError (ResponseResult 'WindowWorkDoneProgressCreate)
    -> m ())
-> m (LspId 'WindowWorkDoneProgressCreate)
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Either ResponseError Empty -> IO ())
-> Either ResponseError Empty
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Barrier (Either ResponseError Empty)
-> Either ResponseError Empty -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier (Either ResponseError Empty)
b
            Either ResponseError Empty
ready <- IO (Either ResponseError Empty) -> m (Either ResponseError Empty)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Empty) -> m (Either ResponseError Empty))
-> IO (Either ResponseError Empty)
-> m (Either ResponseError Empty)
forall a b. (a -> b) -> a -> b
$ Barrier (Either ResponseError Empty)
-> IO (Either ResponseError Empty)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either ResponseError Empty)
b

            Either ResponseError Empty -> (Empty -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either ResponseError Empty
ready ((Empty -> m Any) -> m ()) -> (Empty -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ m Any -> Empty -> m Any
forall a b. a -> b -> a
const (m Any -> Empty -> m Any) -> m Any -> Empty -> m Any
forall a b. (a -> b) -> a -> b
$ m () -> m () -> m Any -> m Any
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ (ProgressToken -> m ()
forall config (f :: * -> *).
MonadLsp config f =>
ProgressToken -> f ()
start ProgressToken
u) (ProgressToken -> m ()
forall config (f :: * -> *).
MonadLsp config f =>
ProgressToken -> f ()
stop ProgressToken
u) (ProgressToken -> UInt -> m Any
forall (f :: * -> *) config b.
MonadLsp config f =>
ProgressToken -> UInt -> f b
loop ProgressToken
u UInt
0)
            where
                start :: ProgressToken -> f ()
start ProgressToken
id = SServerMethod 'Progress -> MessageParams 'Progress -> f ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Progress
LSP.SProgress (MessageParams 'Progress -> f ())
-> MessageParams 'Progress -> f ()
forall a b. (a -> b) -> a -> b
$
                    ProgressParams :: forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams
                        { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                        , $sel:_value:ProgressParams :: SomeProgressParams
_value = WorkDoneProgressBeginParams -> SomeProgressParams
LSP.Begin (WorkDoneProgressBeginParams -> SomeProgressParams)
-> WorkDoneProgressBeginParams -> SomeProgressParams
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressBeginParams :: Text
-> Maybe Bool
-> Maybe Text
-> Maybe UInt
-> WorkDoneProgressBeginParams
WorkDoneProgressBeginParams
                          { $sel:_title:WorkDoneProgressBeginParams :: Text
_title = Text
"Processing"
                          , $sel:_cancellable:WorkDoneProgressBeginParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                          , $sel:_message:WorkDoneProgressBeginParams :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                          , $sel:_percentage:WorkDoneProgressBeginParams :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                          }
                        }
                stop :: ProgressToken -> f ()
stop ProgressToken
id = SServerMethod 'Progress -> MessageParams 'Progress -> f ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Progress
LSP.SProgress
                    ProgressParams :: forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams
                        { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                        , $sel:_value:ProgressParams :: SomeProgressParams
_value = WorkDoneProgressEndParams -> SomeProgressParams
LSP.End WorkDoneProgressEndParams :: Maybe Text -> WorkDoneProgressEndParams
WorkDoneProgressEndParams
                          { $sel:_message:WorkDoneProgressEndParams :: 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 (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
id UInt
prevPct = do
                    Int
done <- IO Int -> f Int
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 (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 (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
id 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 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 'Progress -> MessageParams 'Progress -> f ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Progress
LSP.SProgress (MessageParams 'Progress -> f ())
-> MessageParams 'Progress -> f ()
forall a b. (a -> b) -> a -> b
$
                          ProgressParams :: forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams
                              { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                              , $sel:_value:ProgressParams :: SomeProgressParams
_value = WorkDoneProgressReportParams -> SomeProgressParams
LSP.Report (WorkDoneProgressReportParams -> SomeProgressParams)
-> WorkDoneProgressReportParams -> SomeProgressParams
forall a b. (a -> b) -> a -> b
$ case ProgressReportingStyle
optProgressStyle of
                                  ProgressReportingStyle
Explicit -> WorkDoneProgressReportParams :: Maybe Bool
-> Maybe Text -> Maybe UInt -> WorkDoneProgressReportParams
LSP.WorkDoneProgressReportParams
                                    { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                                    , $sel:_message:WorkDoneProgressReportParams :: 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:WorkDoneProgressReportParams :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                                    }
                                  ProgressReportingStyle
Percentage -> WorkDoneProgressReportParams :: Maybe Bool
-> Maybe Text -> Maybe UInt -> WorkDoneProgressReportParams
LSP.WorkDoneProgressReportParams
                                    { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                                    , $sel:_message:WorkDoneProgressReportParams :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                                    , $sel:_percentage:WorkDoneProgressReportParams :: Maybe UInt
_percentage = UInt -> Maybe UInt
forall a. a -> Maybe a
Just UInt
nextPct
                                    }
                                  ProgressReportingStyle
NoProgress -> String -> WorkDoneProgressReportParams
forall a. Partial => String -> a
error String
"unreachable"
                              }
                        ProgressToken -> UInt -> f b
loop ProgressToken
id 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 :: 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 (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 :: 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 (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