Skip to content

Refactor delayedProgressReporting lsp progress api #4206

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 11 commits into from
Closed

Refactor delayedProgressReporting lsp progress api #4206

Changes from all commits
Commits
Show all changes
11 commits
Select commit Hold shift + click to select a range
ee58e51
switch delayedProgressReporting to use lsp api
soulomoon May 3, 2024
6440805
fix cancel
soulomoon May 3, 2024
3ff9494
fix
soulomoon May 3, 2024
1880239
cleanup
soulomoon May 3, 2024
d2a4c90
fix
soulomoon May 4, 2024
148353b
pass MVar
soulomoon May 4, 2024
03ed6a4
improve
soulomoon May 4, 2024
89cf085
Merge branch 'master' into soulomoon/use-lsp-progress-api-progressRep…
soulomoon May 4, 2024
810db64
fix
soulomoon May 4, 2024
a3ce7d0
async the progressReporting thread
soulomoon May 4, 2024
22f2641
try to cancel and wait
soulomoon May 4, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
96 changes: 33 additions & 63 deletions ghcide/src/Development/IDE/Core/ProgressReporting.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -12,11 +12,13 @@ module Development.IDE.Core.ProgressReporting
)
where

import Control.Concurrent.Async
import Control.Concurrent.STM.Stats (TVar, atomicallyNamed,
modifyTVar', newTVarIO,
readTVarIO)
import Control.Concurrent.Strict
import Control.Concurrent.Strict (Barrier, MVar, modifyVar_,
newBarrier, newEmptyMVar,
newVar, signalBarrier,
threadDelay, waitBarrier)
import Control.Monad.Extra hiding (loop)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
Expand All @@ -33,9 +35,17 @@ import qualified Focus
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import qualified Language.LSP.Protocol.Types as LSP
import Language.LSP.Server (ProgressAmount (..),
ProgressCancellable (..),
withProgress)
import qualified Language.LSP.Server as LSP
import qualified StmContainers.Map as STM
import System.Time.Extra
import UnliftIO (MonadUnliftIO (..),
UnliftIO (unliftIO), async,
newMVar, putMVar, race,
readMVar, toIO, wait, waitAny,
waitAnyCancel)
import UnliftIO.Exception (bracket_)

data ProgressEvent
Expand All @@ -59,18 +69,18 @@ noProgressReporting = return $ ProgressReporting
data State
= NotStarted
| Stopped
| Running (Async ())
| Running (IO ())

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

updateState :: IO (Async ()) -> Transition -> State -> IO State
updateState :: IO () -> Transition -> State -> IO State
updateState _ _ Stopped = pure Stopped
updateState start (Event KickStarted) NotStarted = Running <$> start
updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> start
updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted
updateState start (Event KickStarted) NotStarted = pure $ Running start
updateState start (Event KickStarted) (Running a) = a $> Running start
updateState _ (Event KickCompleted) (Running a) = a $> NotStarted
updateState _ (Event KickCompleted) st = pure st
updateState _ StopProgress (Running a) = cancel a $> Stopped
updateState _ StopProgress (Running a) = a $> Stopped
updateState _ StopProgress st = pure st

-- | Data structure to track progress across the project
Expand All @@ -93,7 +103,7 @@ recordProgress InProgressState{..} file shift = do
(Just 0, 0) -> pure ()
(Just 0, _) -> modifyTVar' doneVar pred
(Just _, 0) -> modifyTVar' doneVar (+1)
(Just _, _) -> pure()
(Just _, _) -> pure ()
where
alterPrevAndNew = do
prev <- Focus.lookup
Expand All @@ -102,6 +112,7 @@ recordProgress InProgressState{..} file shift = do
return (prev, new)
alter x = let x' = maybe (shift 0) shift x in Just 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).
Expand All @@ -117,76 +128,35 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = do
progressState <- newVar NotStarted
let progressUpdate event = updateStateVar $ Event event
progressStop = updateStateVar StopProgress
updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState)

updateStateVar tran = do
start <- lspShakeProgressNew inProgressState
modifyVar_ progressState $ updateState start tran
inProgress = updateStateForFile inProgressState
return ProgressReporting{..}
where
lspShakeProgress InProgressState{..} = do
lspShakeProgressNew InProgressState{..} = do
-- first sleep a bit, so we only show progress messages if it's going to take
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah, I would actually really like to do this in lsp as well, see haskell/lsp#549

-- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
liftIO $ sleep before
u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique

b <- liftIO newBarrier
void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate
LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b
liftIO $ async $ do
ready <- waitBarrier b
LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
cancelProgressB <- newBarrier
job <- async $ LSP.runLspT lspEnv $ withProgress "Processing" Nothing Cancellable $ \update ->
race (liftIO $ waitBarrier cancelProgressB) (loop update 0)
return (signalBarrier cancelProgressB () >> wait job >> return ())
where
start token = LSP.sendNotification SMethod_Progress $
LSP.ProgressParams
{ _token = token
, _value = toJSON $ WorkDoneProgressBegin
{ _kind = AString @"begin"
, _title = "Processing"
, _cancellable = Nothing
, _message = Nothing
, _percentage = Nothing
}
}
stop token = LSP.sendNotification SMethod_Progress
LSP.ProgressParams
{ _token = token
, _value = toJSON $ WorkDoneProgressEnd
{ _kind = AString @"end"
, _message = Nothing
}
}
loop _ _ | optProgressStyle == NoProgress =
forever $ liftIO $ threadDelay maxBound
loop token prevPct = do
loop update prevPct = do
done <- liftIO $ readTVarIO doneVar
todo <- liftIO $ readTVarIO todoVar
liftIO $ sleep after
if todo == 0 then loop token 0 else do
let
nextFrac :: Double
if todo == 0 then loop update 0 else do
let nextFrac :: Double
nextFrac = fromIntegral done / fromIntegral todo
nextPct :: UInt
nextPct = floor $ 100 * nextFrac
when (nextPct /= prevPct) $
LSP.sendNotification SMethod_Progress $
LSP.ProgressParams
{ _token = token
, _value = case optProgressStyle of
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We've lost this progress-style configurability, but honestly, configurability is bad, so better to get rid of it IMO!

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We should get rid of the option as well, I guess.

Explicit -> toJSON $ WorkDoneProgressReport
{ _kind = AString @"report"
, _cancellable = Nothing
, _message = Just $ T.pack $ show done <> "/" <> show todo
, _percentage = Nothing
}
Percentage -> toJSON $ WorkDoneProgressReport
{ _kind = AString @"report"
, _cancellable = Nothing
, _message = Nothing
, _percentage = Just nextPct
}
NoProgress -> error "unreachable"
}
loop token nextPct

update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))
loop update nextPct
updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const
-- This functions are deliberately eta-expanded to avoid space leaks.
-- Do not remove the eta-expansion without profiling a session with at
Expand Down
Loading