{-# LANGUAGE RankNTypes #-}
module Development.IDE.Core.ProgressReporting
( ProgressEvent(..)
, ProgressReporting(..)
, noProgressReporting
, delayedProgressReporting
, mRunLspT
, mRunLspTCallback
, 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 ()
}
data State
= NotStarted
| Stopped
| Running (Async ())
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 InProgress = InProgress
{ InProgress -> Int
todo :: !Int
, InProgress -> Int
done :: !Int
, 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')
delayedProgressReporting
:: Seconds
-> Seconds
-> 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
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
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