Skip to content

Commit 59c28bd

Browse files
pepeiborrapepeiborra
committed
simplify the outer loop away
1 parent c4c9cb9 commit 59c28bd

File tree

1 file changed

+56
-85
lines changed

1 file changed

+56
-85
lines changed

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

Lines changed: 56 additions & 85 deletions
Original file line numberDiff line numberDiff line change
@@ -11,11 +11,9 @@ module Development.IDE.Core.ProgressReporting
1111
where
1212

1313
import Control.Concurrent.Async
14-
import Control.Concurrent.STM
1514
import Control.Concurrent.Strict
1615
import Control.Monad.Extra
1716
import Control.Monad.IO.Class
18-
import qualified Control.Monad.STM as STM
1917
import Control.Monad.Trans.Class (lift)
2018
import Data.Foldable (for_)
2119
import qualified Data.HashMap.Strict as HMap
@@ -60,96 +58,69 @@ delayedProgressReporting
6058
-> IO ProgressReporting
6159
delayedProgressReporting before after lspEnv optProgressStyle = do
6260
inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int)
63-
mostRecentProgressEvent <- newTVarIO KickCompleted
64-
progressAsync <- async $
65-
progressThread optProgressStyle mostRecentProgressEvent inProgressVar
66-
let progressUpdate = atomically . writeTVar mostRecentProgressEvent
67-
progressStop = cancel progressAsync
61+
progressThread <- newVar =<< async (pure ())
62+
let progressUpdate KickStarted = writeVar progressThread =<< async (mRunLspT lspEnv $ lspShakeProgress inProgressVar)
63+
progressUpdate KickCompleted = readVar progressThread >>= cancel
64+
progressStop = progressUpdate KickCompleted
6865
inProgress :: NormalizedFilePath -> Action a -> Action a
6966
inProgress = withProgressVar inProgressVar
7067
return ProgressReporting{..}
7168
where
72-
-- The progress thread is a state machine with two states:
73-
-- 1. Idle
74-
-- 2. Reporting a kick event
75-
-- And two transitions, modelled by 'ProgressEvent':
76-
-- 1. KickCompleted - transitions from Reporting into Idle
77-
-- 2. KickStarted - transitions from Idle into Reporting
78-
progressThread style mostRecentProgressEvent inProgress = progressLoopIdle
79-
where
80-
progressLoopIdle = do
81-
atomically $ do
82-
v <- readTVar mostRecentProgressEvent
83-
case v of
84-
KickCompleted -> STM.retry
85-
KickStarted -> return ()
86-
asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress
87-
progressLoopReporting asyncReporter
88-
progressLoopReporting asyncReporter = do
89-
atomically $ do
90-
v <- readTVar mostRecentProgressEvent
91-
case v of
92-
KickStarted -> STM.retry
93-
KickCompleted -> return ()
94-
cancel asyncReporter
95-
progressLoopIdle
69+
lspShakeProgress inProgress = do
70+
-- first sleep a bit, so we only show progress messages if it's going to take
71+
-- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
72+
liftIO $ sleep before
73+
u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
9674

97-
lspShakeProgress :: LSP.LspM config ()
98-
lspShakeProgress = do
99-
-- first sleep a bit, so we only show progress messages if it's going to take
100-
-- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
101-
liftIO $ sleep before
102-
u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
75+
b <- liftIO newBarrier
76+
void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
77+
LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b
78+
ready <- liftIO $ waitBarrier b
10379

104-
b <- liftIO newBarrier
105-
void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
106-
LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b
107-
ready <- liftIO $ waitBarrier b
108-
109-
for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
110-
where
111-
start id = LSP.sendNotification LSP.SProgress $
112-
LSP.ProgressParams
113-
{ _token = id
114-
, _value = LSP.Begin $ WorkDoneProgressBeginParams
115-
{ _title = "Processing"
116-
, _cancellable = Nothing
117-
, _message = Nothing
118-
, _percentage = Nothing
119-
}
120-
}
121-
stop id = LSP.sendNotification LSP.SProgress
122-
LSP.ProgressParams
123-
{ _token = id
124-
, _value = LSP.End WorkDoneProgressEndParams
125-
{ _message = Nothing
80+
for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
81+
where
82+
start id = LSP.sendNotification LSP.SProgress $
83+
LSP.ProgressParams
84+
{ _token = id
85+
, _value = LSP.Begin $ WorkDoneProgressBeginParams
86+
{ _title = "Processing"
87+
, _cancellable = Nothing
88+
, _message = Nothing
89+
, _percentage = Nothing
90+
}
91+
}
92+
stop id = LSP.sendNotification LSP.SProgress
93+
LSP.ProgressParams
94+
{ _token = id
95+
, _value = LSP.End WorkDoneProgressEndParams
96+
{ _message = Nothing
97+
}
98+
}
99+
loop id prev = do
100+
current <- liftIO $ readVar inProgress
101+
let done = length $ filter (== 0) $ HMap.elems current
102+
let todo = HMap.size current
103+
if todo == 0 then loop id 0 else do
104+
let next = 100 * fromIntegral done / fromIntegral todo
105+
liftIO $ sleep after
106+
when (optProgressStyle /= NoProgress && next /= prev) $
107+
LSP.sendNotification LSP.SProgress $
108+
LSP.ProgressParams
109+
{ _token = id
110+
, _value = LSP.Report $ case optProgressStyle of
111+
Explicit -> LSP.WorkDoneProgressReportParams
112+
{ _cancellable = Nothing
113+
, _message = Just $ T.pack $ show done <> "/" <> show todo
114+
, _percentage = Nothing
115+
}
116+
Percentage -> LSP.WorkDoneProgressReportParams
117+
{ _cancellable = Nothing
118+
, _message = Nothing
119+
, _percentage = Just next
120+
}
121+
NoProgress -> error "unreachable"
126122
}
127-
}
128-
loop id prev = do
129-
current <- liftIO $ readVar inProgress
130-
let done = length $ filter (== 0) $ HMap.elems current
131-
let todo = HMap.size current
132-
if todo == 0 then loop id 0 else do
133-
let next = 100 * fromIntegral done / fromIntegral todo
134-
liftIO $ sleep after
135-
when (style /= NoProgress && next /= prev) $
136-
LSP.sendNotification LSP.SProgress $
137-
LSP.ProgressParams
138-
{ _token = id
139-
, _value = LSP.Report $ case style of
140-
Explicit -> LSP.WorkDoneProgressReportParams
141-
{ _cancellable = Nothing
142-
, _message = Just $ T.pack $ show done <> "/" <> show todo
143-
, _percentage = Nothing
144-
}
145-
Percentage -> LSP.WorkDoneProgressReportParams
146-
{ _cancellable = Nothing
147-
, _message = Nothing
148-
, _percentage = Just next
149-
}
150-
NoProgress -> error "unreachable"
151-
}
152-
loop id next
123+
loop id next
153124

154125
withProgressVar var file = actionBracket (f succ) (const $ f pred) . const
155126
-- This functions are deliberately eta-expanded to avoid space leaks.

0 commit comments

Comments
 (0)