From ee58e51d7a44dae8f68078beb2ae6f802f23ac36 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 05:23:52 +0800 Subject: [PATCH 01/10] switch delayedProgressReporting to use lsp api --- .../Development/IDE/Core/ProgressReporting.hs | 67 ++++--------------- 1 file changed, 13 insertions(+), 54 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2b7de8049e..47e24f837f 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -33,9 +33,14 @@ 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), toIO) import UnliftIO.Exception (bracket_) data ProgressEvent @@ -117,76 +122,30 @@ 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 = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) 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 -- 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) + async $ LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0 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 - 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 From 64408054362ee02ed3fc755ec322aa801ccac38f Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 07:14:19 +0800 Subject: [PATCH 02/10] fix cancel --- .../Development/IDE/Core/ProgressReporting.hs | 34 ++++++++++++++----- 1 file changed, 26 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 47e24f837f..ae2803287e 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -39,8 +39,10 @@ import Language.LSP.Server (ProgressAmount (..), import qualified Language.LSP.Server as LSP import qualified StmContainers.Map as STM import System.Time.Extra +import qualified UnliftIO as MonadUnliftIO import UnliftIO (MonadUnliftIO (..), - UnliftIO (unliftIO), toIO) + UnliftIO (unliftIO), newMVar, + putMVar, toIO) import UnliftIO.Exception (bracket_) data ProgressEvent @@ -64,18 +66,18 @@ noProgressReporting = return $ ProgressReporting data State = NotStarted | Stopped - | Running (Async ()) + | Running (IO (IO ())) -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: IO (Async ()) -> Transition -> State -> IO State +updateState :: IO (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) = join a $> Running start +updateState _ (Event KickCompleted) (Running a) = join a $> NotStarted updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running a) = cancel a $> Stopped +updateState _ StopProgress (Running a) = join a $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project @@ -107,6 +109,12 @@ recordProgress InProgressState{..} file shift = do return (prev, new) alter x = let x' = maybe (shift 0) shift x in Just x' +-- | Runs the action until it ends or until the given MVar is put. +-- Rethrows any exceptions. +untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () +untilMVar mvar io = void $ + MonadUnliftIO.waitAnyCancel =<< traverse MonadUnliftIO.async [ io , MonadUnliftIO.readMVar mvar ] + -- | 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). @@ -130,8 +138,18 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = 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) liftIO $ sleep before - async $ LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0 + cancelProgress <- Control.Concurrent.Strict.newEmptyMVar + LSP.runLspT lspEnv $ do + u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique + b <- liftIO newBarrier + LSP.sendRequest SMethod_WindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b + return $ async $ do + ready <- waitBarrier b + LSP.runLspT lspEnv $ withProgress "Processing" (Just u) Cancellable $ \update -> loopUntil cancelProgress update 0 + return (Control.Concurrent.Strict.putMVar cancelProgress ()) where + loopUntil m a b = untilMVar m $ loop a b loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop update prevPct = do From 3ff949432e9c583158ea8abaa94abcf1ab8f0126 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 07:48:03 +0800 Subject: [PATCH 03/10] fix --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index ae2803287e..1118051bbe 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -77,7 +77,7 @@ updateState start (Event KickStarted) NotStarted = pure $ Running start updateState start (Event KickStarted) (Running a) = join a $> Running start updateState _ (Event KickCompleted) (Running a) = join a $> NotStarted updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running a) = join a $> Stopped +updateState _ StopProgress (Running a) = a $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project @@ -144,7 +144,7 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = do b <- liftIO newBarrier LSP.sendRequest SMethod_WindowWorkDoneProgressCreate LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b - return $ async $ do + liftIO $ async $ do ready <- waitBarrier b LSP.runLspT lspEnv $ withProgress "Processing" (Just u) Cancellable $ \update -> loopUntil cancelProgress update 0 return (Control.Concurrent.Strict.putMVar cancelProgress ()) From 18802399ebadcdaddb6f71507e9a822ee4a35629 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 07:57:09 +0800 Subject: [PATCH 04/10] cleanup --- .../Development/IDE/Core/ProgressReporting.hs | 24 ++++++++++--------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 1118051bbe..b49f1404f0 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -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 (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) @@ -39,10 +41,10 @@ import Language.LSP.Server (ProgressAmount (..), import qualified Language.LSP.Server as LSP import qualified StmContainers.Map as STM import System.Time.Extra -import qualified UnliftIO as MonadUnliftIO import UnliftIO (MonadUnliftIO (..), - UnliftIO (unliftIO), newMVar, - putMVar, toIO) + UnliftIO (unliftIO), async, + newMVar, putMVar, readMVar, + toIO, waitAnyCancel) import UnliftIO.Exception (bracket_) data ProgressEvent @@ -113,7 +115,7 @@ recordProgress InProgressState{..} file shift = do -- Rethrows any exceptions. untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () untilMVar mvar io = void $ - MonadUnliftIO.waitAnyCancel =<< traverse MonadUnliftIO.async [ io , MonadUnliftIO.readMVar mvar ] + waitAnyCancel =<< traverse async [ io , readMVar mvar ] -- | A 'ProgressReporting' that enqueues Begin and End notifications in a new -- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives @@ -138,16 +140,16 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = 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) liftIO $ sleep before - cancelProgress <- Control.Concurrent.Strict.newEmptyMVar + cancelProgress <- newEmptyMVar LSP.runLspT lspEnv $ do u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique b <- liftIO newBarrier LSP.sendRequest SMethod_WindowWorkDoneProgressCreate LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b - liftIO $ async $ do - ready <- waitBarrier b - LSP.runLspT lspEnv $ withProgress "Processing" (Just u) Cancellable $ \update -> loopUntil cancelProgress update 0 - return (Control.Concurrent.Strict.putMVar cancelProgress ()) + async $ do + ready <- liftIO $ waitBarrier b + withProgress "Processing" (Just u) Cancellable $ \update -> loopUntil cancelProgress update 0 + return (putMVar cancelProgress ()) where loopUntil m a b = untilMVar m $ loop a b loop _ _ | optProgressStyle == NoProgress = From d2a4c90a361c9baa5bd7760b9335d73295188d2f Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 08:08:52 +0800 Subject: [PATCH 05/10] fix --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index b49f1404f0..7e4731b689 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -79,7 +79,7 @@ updateState start (Event KickStarted) NotStarted = pure $ Running start updateState start (Event KickStarted) (Running a) = join a $> Running start updateState _ (Event KickCompleted) (Running a) = join a $> NotStarted updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running a) = a $> Stopped +updateState _ StopProgress (Running a) = join a $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project From 148353b5e0b8c2d9504bb254aa7028cb42654f8b Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 08:38:33 +0800 Subject: [PATCH 06/10] pass MVar --- .../Development/IDE/Core/ProgressReporting.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 7e4731b689..438d391d16 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -68,18 +68,18 @@ noProgressReporting = return $ ProgressReporting data State = NotStarted | Stopped - | Running (IO (IO ())) + | Running (MVar ()) -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: IO (IO ()) -> Transition -> State -> IO State +updateState :: MVar () -> Transition -> State -> IO State updateState _ _ Stopped = pure Stopped updateState start (Event KickStarted) NotStarted = pure $ Running start -updateState start (Event KickStarted) (Running a) = join a $> Running start -updateState _ (Event KickCompleted) (Running a) = join a $> NotStarted +updateState start (Event KickStarted) (Running a) = putMVar a () $> Running start +updateState _ (Event KickCompleted) (Running a) = putMVar a () $> NotStarted updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running a) = join a $> Stopped +updateState _ StopProgress (Running a) = putMVar a () $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project @@ -102,7 +102,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 @@ -132,7 +132,9 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = do progressState <- newVar NotStarted let progressUpdate event = updateStateVar $ Event event progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) + updateStateVar tran = do + start <- lspShakeProgressNew inProgressState + modifyVar_ progressState $ updateState start tran inProgress = updateStateForFile inProgressState return ProgressReporting{..} where @@ -149,7 +151,7 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = do async $ do ready <- liftIO $ waitBarrier b withProgress "Processing" (Just u) Cancellable $ \update -> loopUntil cancelProgress update 0 - return (putMVar cancelProgress ()) + return cancelProgress where loopUntil m a b = untilMVar m $ loop a b loop _ _ | optProgressStyle == NoProgress = From 03ed6a49c9ef3f6008a6b4094e4741aee5d22adf Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 21:31:18 +0800 Subject: [PATCH 07/10] improve --- .../Development/IDE/Core/ProgressReporting.hs | 38 +++++++------------ 1 file changed, 13 insertions(+), 25 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 438d391d16..b6f29b4b2b 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -15,10 +15,10 @@ module Development.IDE.Core.ProgressReporting import Control.Concurrent.STM.Stats (TVar, atomicallyNamed, modifyTVar', newTVarIO, readTVarIO) -import Control.Concurrent.Strict (MVar, modifyVar_, newBarrier, - newEmptyMVar, newVar, - signalBarrier, threadDelay, - waitBarrier) +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) @@ -43,8 +43,8 @@ import qualified StmContainers.Map as STM import System.Time.Extra import UnliftIO (MonadUnliftIO (..), UnliftIO (unliftIO), async, - newMVar, putMVar, readMVar, - toIO, waitAnyCancel) + newMVar, putMVar, race, + readMVar, toIO, waitAnyCancel) import UnliftIO.Exception (bracket_) data ProgressEvent @@ -68,16 +68,16 @@ noProgressReporting = return $ ProgressReporting data State = NotStarted | Stopped - | Running (MVar ()) + | Running (Barrier ()) -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: MVar () -> Transition -> State -> IO State +updateState :: Barrier () -> Transition -> State -> IO State updateState _ _ Stopped = pure Stopped updateState start (Event KickStarted) NotStarted = pure $ Running start -updateState start (Event KickStarted) (Running a) = putMVar a () $> Running start -updateState _ (Event KickCompleted) (Running a) = putMVar a () $> NotStarted +updateState start (Event KickStarted) (Running a) = signalBarrier a () $> Running start +updateState _ (Event KickCompleted) (Running a) = signalBarrier a () $> NotStarted updateState _ (Event KickCompleted) st = pure st updateState _ StopProgress (Running a) = putMVar a () $> Stopped updateState _ StopProgress st = pure st @@ -111,11 +111,6 @@ recordProgress InProgressState{..} file shift = do return (prev, new) alter x = let x' = maybe (shift 0) shift x in Just x' --- | Runs the action until it ends or until the given MVar is put. --- Rethrows any exceptions. -untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () -untilMVar mvar io = void $ - waitAnyCancel =<< traverse async [ io , readMVar mvar ] -- | A 'ProgressReporting' that enqueues Begin and End notifications in a new -- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives @@ -142,18 +137,11 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = 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) liftIO $ sleep before - cancelProgress <- newEmptyMVar - LSP.runLspT lspEnv $ do - u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique - b <- liftIO newBarrier - LSP.sendRequest SMethod_WindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b - async $ do - ready <- liftIO $ waitBarrier b - withProgress "Processing" (Just u) Cancellable $ \update -> loopUntil cancelProgress update 0 + cancelProgress <- newBarrier + LSP.runLspT lspEnv $ withProgress "Processing" Nothing Cancellable $ \update -> + race (liftIO $ waitBarrier cancelProgress) (loop update 0) return cancelProgress where - loopUntil m a b = untilMVar m $ loop a b loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop update prevPct = do From 810db64d0a51d96f37030fb832b4434f9a157d4a Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 21:37:58 +0800 Subject: [PATCH 08/10] fix --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index b6f29b4b2b..3879b2d2a2 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -79,7 +79,7 @@ updateState start (Event KickStarted) NotStarted = pure $ Running start updateState start (Event KickStarted) (Running a) = signalBarrier a () $> Running start updateState _ (Event KickCompleted) (Running a) = signalBarrier a () $> NotStarted updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running a) = putMVar a () $> Stopped +updateState _ StopProgress (Running a) = signalBarrier a () $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project From a3ce7d037b6676bb6918cd56e5493c0dd9a67a99 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 5 May 2024 02:26:02 +0800 Subject: [PATCH 09/10] async the progressReporting thread --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 3879b2d2a2..d76bb3e583 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -138,7 +138,7 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = do -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) liftIO $ sleep before cancelProgress <- newBarrier - LSP.runLspT lspEnv $ withProgress "Processing" Nothing Cancellable $ \update -> + async $ LSP.runLspT lspEnv $ withProgress "Processing" Nothing Cancellable $ \update -> race (liftIO $ waitBarrier cancelProgress) (loop update 0) return cancelProgress where From 22f2641afd72eed770ad2ca06745936c2449f830 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 5 May 2024 03:02:37 +0800 Subject: [PATCH 10/10] try to cancel and wait --- .../Development/IDE/Core/ProgressReporting.hs | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index d76bb3e583..4eaafe8e90 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -44,7 +44,8 @@ import System.Time.Extra import UnliftIO (MonadUnliftIO (..), UnliftIO (unliftIO), async, newMVar, putMVar, race, - readMVar, toIO, waitAnyCancel) + readMVar, toIO, wait, waitAny, + waitAnyCancel) import UnliftIO.Exception (bracket_) data ProgressEvent @@ -68,18 +69,18 @@ noProgressReporting = return $ ProgressReporting data State = NotStarted | Stopped - | Running (Barrier ()) + | Running (IO ()) -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: Barrier () -> Transition -> State -> IO State +updateState :: IO () -> Transition -> State -> IO State updateState _ _ Stopped = pure Stopped updateState start (Event KickStarted) NotStarted = pure $ Running start -updateState start (Event KickStarted) (Running a) = signalBarrier a () $> Running start -updateState _ (Event KickCompleted) (Running a) = signalBarrier a () $> NotStarted +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) = signalBarrier a () $> Stopped +updateState _ StopProgress (Running a) = a $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project @@ -137,10 +138,10 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = 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) liftIO $ sleep before - cancelProgress <- newBarrier - async $ LSP.runLspT lspEnv $ withProgress "Processing" Nothing Cancellable $ \update -> - race (liftIO $ waitBarrier cancelProgress) (loop update 0) - return cancelProgress + 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 loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound