{-# LANGUAGE RankNTypes #-}
module Development.IDE.Core.ProgressReporting
  ( ProgressEvent(..)
  , ProgressReporting(..)
  , noProgressReporting
  , delayedProgressReporting
  -- utilities, reexported for use in Core.Shake
  , mRunLspT
  , mRunLspTCallback
  -- for tests
  , recordProgress
  , InProgress(..)
  )
   where

import           Control.Concurrent.Async
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.HashMap.Strict            as HMap
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 Language.LSP.Server            as LSP
import           Language.LSP.Types
import qualified Language.LSP.Types             as LSP
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 InProgress = InProgress
    { InProgress -> Int
todo    :: !Int  -- ^ Number of files to do
    , InProgress -> Int
done    :: !Int  -- ^ Number of files done
    , InProgress -> HashMap NormalizedFilePath Int
current :: !(HMap.HashMap NormalizedFilePath Int)
    }

recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress
recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress
recordProgress NormalizedFilePath
file Int -> Int
shift InProgress{Int
HashMap NormalizedFilePath Int
current :: HashMap NormalizedFilePath Int
done :: Int
todo :: Int
current :: InProgress -> HashMap NormalizedFilePath Int
done :: InProgress -> Int
todo :: InProgress -> Int
..} = case (Maybe Int -> ((Maybe Int, Int), Maybe Int))
-> NormalizedFilePath
-> HashMap NormalizedFilePath Int
-> ((Maybe Int, Int), HashMap NormalizedFilePath Int)
forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
HMap.alterF Maybe Int -> ((Maybe Int, Int), Maybe Int)
alter NormalizedFilePath
file HashMap NormalizedFilePath Int
current of
    ((Maybe Int
prev, Int
new), HashMap NormalizedFilePath Int
m') ->
        let (Int
done',Int
todo') =
                case (Maybe Int
prev,Int
new) of
                    (Maybe Int
Nothing,Int
0) -> (Int
doneInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
todoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                    (Maybe Int
Nothing,Int
_) -> (Int
done,   Int
todoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                    (Just Int
0, Int
0) -> (Int
done  , Int
todo)
                    (Just Int
0, Int
_) -> (Int
doneInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
todo)
                    (Just Int
_, Int
0) -> (Int
doneInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
todo)
                    (Just Int
_, Int
_) -> (Int
done  , Int
todo)
        in Int -> Int -> HashMap NormalizedFilePath Int -> InProgress
InProgress Int
todo' Int
done' HashMap NormalizedFilePath Int
m'
  where
    alter :: Maybe Int -> ((Maybe Int, 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 ((Maybe Int
x,Int
x'), 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
    Var InProgress
inProgressVar <- InProgress -> IO (Var InProgress)
forall a. a -> IO (Var a)
newVar (InProgress -> IO (Var InProgress))
-> InProgress -> IO (Var InProgress)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> HashMap NormalizedFilePath Int -> InProgress
InProgress Int
0 Int
0 HashMap NormalizedFilePath Int
forall a. Monoid a => a
mempty
    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
$ Var InProgress -> LspT c IO ()
forall config (m :: * -> *).
MonadLsp config m =>
Var InProgress -> m ()
lspShakeProgress Var InProgress
inProgressVar)

        inProgress :: NormalizedFilePath -> Action a -> Action a
        inProgress :: NormalizedFilePath -> Action a -> Action a
inProgress = Var InProgress -> NormalizedFilePath -> Action a -> Action a
forall c.
Var InProgress -> NormalizedFilePath -> Action c -> Action c
withProgressVar Var InProgress
inProgressVar
    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 :: Var InProgress -> m ()
lspShakeProgress Var InProgress
inProgress = 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 -> Seconds -> m Any
forall (f :: * -> *) config b.
MonadLsp config f =>
ProgressToken -> Seconds -> f b
loop ProgressToken
u Seconds
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 Seconds
-> 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 Seconds
_percentage = Maybe Seconds
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 -> Seconds -> f b
loop ProgressToken
_ Seconds
_ | 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 Seconds
prev = do
                    InProgress{Int
HashMap NormalizedFilePath Int
current :: HashMap NormalizedFilePath Int
done :: Int
todo :: Int
current :: InProgress -> HashMap NormalizedFilePath Int
done :: InProgress -> Int
todo :: InProgress -> Int
..} <- IO InProgress -> f InProgress
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InProgress -> f InProgress) -> IO InProgress -> f InProgress
forall a b. (a -> b) -> a -> b
$ Var InProgress -> IO InProgress
forall a. Var a -> IO a
readVar Var InProgress
inProgress
                    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 -> Seconds -> f b
loop ProgressToken
id Seconds
0 else do
                        let next :: Seconds
next = Seconds
100 Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
* 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
                        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Seconds
next Seconds -> Seconds -> Bool
forall a. Eq a => a -> a -> Bool
/= Seconds
prev) (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 Seconds -> 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 Seconds
_percentage = Maybe Seconds
forall a. Maybe a
Nothing
                                    }
                                  ProgressReportingStyle
Percentage -> WorkDoneProgressReportParams :: Maybe Bool
-> Maybe Text -> Maybe Seconds -> 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 Seconds
_percentage = Seconds -> Maybe Seconds
forall a. a -> Maybe a
Just Seconds
next
                                    }
                                  ProgressReportingStyle
NoProgress -> String -> WorkDoneProgressReportParams
forall a. Partial => String -> a
error String
"unreachable"
                              }
                        ProgressToken -> Seconds -> f b
loop ProgressToken
id Seconds
next

        withProgressVar :: Var InProgress -> NormalizedFilePath -> Action c -> Action c
withProgressVar Var InProgress
var NormalizedFilePath
file = IO InProgress
-> (InProgress -> IO InProgress)
-> (InProgress -> Action c)
-> Action c
forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket ((Int -> Int) -> IO InProgress
f Int -> Int
forall a. Enum a => a -> a
succ) (IO InProgress -> InProgress -> IO InProgress
forall a b. a -> b -> a
const (IO InProgress -> InProgress -> IO InProgress)
-> IO InProgress -> InProgress -> IO InProgress
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO InProgress
f Int -> Int
forall a. Enum a => a -> a
pred) ((InProgress -> Action c) -> Action c)
-> (Action c -> InProgress -> Action c) -> Action c -> Action c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action c -> InProgress -> 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 InProgress
f Int -> Int
shift = Var InProgress -> (InProgress -> InProgress) -> IO InProgress
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var InProgress
var ((InProgress -> InProgress) -> IO InProgress)
-> (InProgress -> InProgress) -> IO InProgress
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress
recordProgress 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