diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2b7de8049e..4eaafe8e90 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 (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) @@ -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 @@ -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 @@ -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 @@ -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). @@ -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 -- 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 - 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