Skip to content

Commit 4987a79

Browse files
pepeiborrapepeiborra
committed
direct progress reporting
1 parent 6cdac37 commit 4987a79

File tree

2 files changed

+162
-98
lines changed

2 files changed

+162
-98
lines changed

‎ghcide/src/Development/IDE/Core/ProgressReporting.hs

Lines changed: 156 additions & 95 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ module Development.IDE.Core.ProgressReporting
77
-- utilities, reexported for use in Core.Shake
88
, mRunLspT
99
, mRunLspTCallback
10-
)
10+
,directProgressReporting)
1111
where
1212

1313
import Control.Concurrent.Async
@@ -17,13 +17,18 @@ import Control.Monad.Extra
1717
import Control.Monad.IO.Class
1818
import qualified Control.Monad.STM as STM
1919
import Control.Monad.Trans.Class (lift)
20+
import Data.Foldable (for_)
21+
import Data.HashMap.Strict (HashMap)
2022
import qualified Data.HashMap.Strict as HMap
23+
import Data.IORef
2124
import qualified Data.Text as T
2225
import Data.Unique
2326
import Development.IDE.GHC.Orphans ()
2427
import Development.IDE.Graph hiding (ShakeValue)
2528
import Development.IDE.Types.Location
2629
import Development.IDE.Types.Options
30+
import GHC.IORef (atomicModifyIORef'_,
31+
atomicSwapIORef)
2732
import qualified Language.LSP.Server as LSP
2833
import Language.LSP.Types
2934
import qualified Language.LSP.Types as LSP
@@ -47,113 +52,169 @@ noProgressReporting = return $ ProgressReporting
4752
, progressStop = pure ()
4853
}
4954

55+
-- | A 'ProgressReporting' that sends the WorkDone Begin and End notifications
56+
-- synchronously. Progress notifications are sent from a sampling thread.
57+
directProgressReporting
58+
:: Double -- ^ sampling rate
59+
-> Maybe (LSP.LanguageContextEnv config)
60+
-> ProgressReportingStyle
61+
-> IO ProgressReporting
62+
directProgressReporting sample env style = do
63+
st <- newIORef Nothing
64+
inProgressVar <- newIORef (HMap.empty @NormalizedFilePath @Int)
65+
66+
let progressUpdate KickStarted = do
67+
u <- newProgressToken
68+
writeIORef st (Just u)
69+
mRunLspT env $ start u
70+
progressUpdate KickCompleted = do
71+
mbToken <- atomicSwapIORef st Nothing
72+
for_ mbToken $ \u ->
73+
mRunLspT env $ stop u
74+
75+
inProgress file = actionBracket (f file succ) (const $ f file pred) . const
76+
-- This function is deliberately eta-expanded to avoid space leaks.
77+
-- Do not remove the eta-expansion without profiling a session with at
78+
-- least 1000 modifications.
79+
f file shift = atomicModifyIORef'_ inProgressVar $
80+
HMap.insertWith (\_ x -> shift x) file (shift 0)
81+
82+
progressLoop :: Double -> LSP.LspM a ()
83+
progressLoop prev = do
84+
mbToken <- liftIO $ readIORef st
85+
case mbToken of
86+
Nothing ->
87+
liftIO (sleep sample) >> progressLoop 0
88+
Just t -> do
89+
current <- liftIO $ readIORef inProgressVar
90+
prev <- progress style prev current t
91+
liftIO $ sleep sample
92+
progressLoop prev
93+
94+
progressThread <- async $ mRunLspT env $ progressLoop 0
95+
let progressStop = cancel progressThread
96+
97+
pure ProgressReporting {..}
98+
99+
-- | A 'ProgressReporting' that enqueues Begin and End notifications in a new
100+
-- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives
101+
-- before the end of the grace period).
102+
-- Avoid using in tests where progress notifications are used to assert invariants.
50103
delayedProgressReporting
51-
:: Maybe (LSP.LanguageContextEnv c)
104+
:: Double -- ^ sampling rate, also used as grace period before Begin
105+
-> Maybe (LSP.LanguageContextEnv c)
52106
-> ProgressReportingStyle
53107
-> IO ProgressReporting
54-
delayedProgressReporting lspEnv optProgressStyle = do
108+
delayedProgressReporting sample lspEnv style = do
55109
inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int)
56110
mostRecentProgressEvent <- newTVarIO KickCompleted
57111
progressAsync <- async $
58-
progressThread optProgressStyle mostRecentProgressEvent inProgressVar
112+
progressThread mostRecentProgressEvent inProgressVar
59113
let progressUpdate = atomically . writeTVar mostRecentProgressEvent
60114
progressStop = cancel progressAsync
61115
inProgress :: NormalizedFilePath -> Action a -> Action a
62116
inProgress = withProgressVar inProgressVar
63117
return ProgressReporting{..}
64-
where
65-
-- The progress thread is a state machine with two states:
66-
-- 1. Idle
67-
-- 2. Reporting a kick event
68-
-- And two transitions, modelled by 'ProgressEvent':
69-
-- 1. KickCompleted - transitions from Reporting into Idle
70-
-- 2. KickStarted - transitions from Idle into Reporting
71-
progressThread style mostRecentProgressEvent inProgress = progressLoopIdle
72-
where
73-
progressLoopIdle = do
74-
atomically $ do
75-
v <- readTVar mostRecentProgressEvent
76-
case v of
77-
KickCompleted -> STM.retry
78-
KickStarted -> return ()
79-
asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress
80-
progressLoopReporting asyncReporter
81-
progressLoopReporting asyncReporter = do
82-
atomically $ do
83-
v <- readTVar mostRecentProgressEvent
84-
case v of
85-
KickStarted -> STM.retry
86-
KickCompleted -> return ()
87-
cancel asyncReporter
88-
progressLoopIdle
89-
90-
lspShakeProgress :: LSP.LspM config ()
91-
lspShakeProgress = do
118+
where
119+
-- The progress thread is a state machine with two states:
120+
-- 1. Idle
121+
-- 2. Reporting a kick event
122+
-- And two transitions, modelled by 'ProgressEvent':
123+
-- 1. KickCompleted - transitions from Reporting into Idle
124+
-- 2. KickStarted - transitions from Idle into Reporting
125+
progressThread mostRecentProgressEvent inProgress = progressLoopIdle
126+
where
127+
progressLoopIdle = do
128+
atomically $ do
129+
v <- readTVar mostRecentProgressEvent
130+
case v of
131+
KickCompleted -> STM.retry
132+
KickStarted -> return ()
133+
asyncReporter <- async $ mRunLspT lspEnv $ do
92134
-- first sleep a bit, so we only show progress messages if it's going to take
93135
-- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
94-
liftIO $ sleep 0.1
95-
u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
96-
97-
void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
98-
LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ())
99-
100-
bracket_
101-
(start u)
102-
(stop u)
103-
(loop u 0)
104-
where
105-
start id = LSP.sendNotification LSP.SProgress $
106-
LSP.ProgressParams
107-
{ _token = id
108-
, _value = LSP.Begin $ WorkDoneProgressBeginParams
109-
{ _title = "Processing"
110-
, _cancellable = Nothing
111-
, _message = Nothing
112-
, _percentage = Nothing
113-
}
114-
}
115-
stop id = LSP.sendNotification LSP.SProgress
116-
LSP.ProgressParams
117-
{ _token = id
118-
, _value = LSP.End WorkDoneProgressEndParams
119-
{ _message = Nothing
120-
}
121-
}
122-
sample = 0.1
123-
loop id prev = do
124-
liftIO $ sleep sample
125-
current <- liftIO $ readVar inProgress
126-
let done = length $ filter (== 0) $ HMap.elems current
127-
let todo = HMap.size current
128-
let next = 100 * fromIntegral done / fromIntegral todo
129-
when (next /= prev) $
130-
LSP.sendNotification LSP.SProgress $
131-
LSP.ProgressParams
132-
{ _token = id
133-
, _value = LSP.Report $ case style of
134-
Explicit -> LSP.WorkDoneProgressReportParams
135-
{ _cancellable = Nothing
136-
, _message = Just $ T.pack $ show done <> "/" <> show todo
137-
, _percentage = Nothing
138-
}
139-
Percentage -> LSP.WorkDoneProgressReportParams
140-
{ _cancellable = Nothing
141-
, _message = Nothing
142-
, _percentage = Just next
143-
}
144-
NoProgress -> LSP.WorkDoneProgressReportParams
145-
{ _cancellable = Nothing
146-
, _message = Nothing
147-
, _percentage = Nothing
148-
}
149-
}
150-
loop id next
151-
152-
withProgressVar var file = actionBracket (f succ) (const $ f pred) . const
153-
-- This functions are deliberately eta-expanded to avoid space leaks.
154-
-- Do not remove the eta-expansion without profiling a session with at
155-
-- least 1000 modifications.
156-
where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0)
136+
liftIO $ sleep sample
137+
lspShakeProgress style inProgress
138+
progressLoopReporting asyncReporter
139+
progressLoopReporting asyncReporter = do
140+
atomically $ do
141+
v <- readTVar mostRecentProgressEvent
142+
case v of
143+
KickStarted -> STM.retry
144+
KickCompleted -> return ()
145+
cancel asyncReporter
146+
progressLoopIdle
147+
148+
lspShakeProgress style inProgress = do
149+
u <- liftIO newProgressToken
150+
151+
void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
152+
LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ())
153+
154+
bracket_ (start u) (stop u) (loop u 0)
155+
where
156+
loop id prev = do
157+
liftIO $ sleep sample
158+
current <- liftIO $ readVar inProgress
159+
next <- progress style prev current id
160+
loop id next
161+
162+
withProgressVar var file = actionBracket (f succ) (const $ f pred) . const
163+
-- This functions are deliberately eta-expanded to avoid space leaks.
164+
-- Do not remove the eta-expansion without profiling a session with at
165+
-- least 1000 modifications.
166+
where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0)
167+
168+
newProgressToken :: IO ProgressToken
169+
newProgressToken = ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
170+
171+
172+
start :: LSP.MonadLsp config f => ProgressToken -> f ()
173+
start id = LSP.sendNotification LSP.SProgress $
174+
LSP.ProgressParams
175+
{ _token = id
176+
, _value = LSP.Begin $ WorkDoneProgressBeginParams
177+
{ _title = "Processing"
178+
, _cancellable = Nothing
179+
, _message = Nothing
180+
, _percentage = Nothing
181+
}
182+
}
183+
stop :: LSP.MonadLsp config f => ProgressToken -> f ()
184+
stop id = LSP.sendNotification LSP.SProgress
185+
LSP.ProgressParams
186+
{ _token = id
187+
, _value = LSP.End WorkDoneProgressEndParams
188+
{ _message = Nothing
189+
}
190+
}
191+
192+
progress :: (LSP.MonadLsp config f) =>
193+
ProgressReportingStyle -> Double -> HashMap NormalizedFilePath Int -> ProgressToken -> f Double
194+
progress style prev current id = do
195+
let done = length $ filter (== 0) $ HMap.elems current
196+
let todo = HMap.size current
197+
let next = 100 * fromIntegral done / fromIntegral todo
198+
when (next /= prev) $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams
199+
{ _token = id
200+
, _value = LSP.Report $ case style of
201+
Explicit -> LSP.WorkDoneProgressReportParams
202+
{ _cancellable = Nothing
203+
, _message = Just $ T.pack $ show done <> "/" <> show todo
204+
, _percentage = Nothing
205+
}
206+
Percentage -> LSP.WorkDoneProgressReportParams
207+
{ _cancellable = Nothing
208+
, _message = Nothing
209+
, _percentage = Just next
210+
}
211+
NoProgress -> LSP.WorkDoneProgressReportParams
212+
{ _cancellable = Nothing
213+
, _message = Nothing
214+
, _percentage = Nothing
215+
}
216+
}
217+
return next
157218

158219
mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()
159220
mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f

‎ghcide/src/Development/IDE/Core/Shake.hs

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -469,7 +469,7 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
469469
-> Rules ()
470470
-> IO IdeState
471471
shakeOpen lspEnv defaultConfig logger debouncer
472-
shakeProfileDir (IdeReportProgress inProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo
472+
shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo
473473

474474
us <- mkSplitUniqSupply 'r'
475475
ideNc <- newIORef (initNameCache us knownKeyNames)
@@ -490,8 +490,11 @@ shakeOpen lspEnv defaultConfig logger debouncer
490490
exportsMap <- newVar mempty
491491

492492
ProgressReporting{..} <-
493-
if inProgress
494-
then delayedProgressReporting lspEnv optProgressStyle
493+
if reportProgress
494+
then (if testing
495+
then directProgressReporting
496+
else delayedProgressReporting
497+
) 0.1 lspEnv optProgressStyle
495498
else noProgressReporting
496499
actionQueue <- newQueue
497500

0 commit comments

Comments
 (0)