|
| 1 | +{-# LANGUAGE RankNTypes #-} |
| 2 | +module Development.IDE.Core.ProgressReporting |
| 3 | + ( ProgressEvent(..) |
| 4 | + , ProgressReporting(..) |
| 5 | + , noProgressReporting |
| 6 | + , delayedProgressReporting |
| 7 | + -- utilities, reexported for use in Core.Shake |
| 8 | + , mRunLspT |
| 9 | + , mRunLspTCallback |
| 10 | + ) |
| 11 | + where |
| 12 | + |
| 13 | +import Control.Concurrent.Async |
| 14 | +import Control.Concurrent.STM |
| 15 | +import Control.Concurrent.Strict |
| 16 | +import Control.Monad.Extra |
| 17 | +import Control.Monad.IO.Class |
| 18 | +import qualified Control.Monad.STM as STM |
| 19 | +import Control.Monad.Trans.Class (lift) |
| 20 | +import qualified Data.HashMap.Strict as HMap |
| 21 | +import qualified Data.Text as T |
| 22 | +import Data.Unique |
| 23 | +import Development.IDE.GHC.Orphans () |
| 24 | +import Development.IDE.Graph hiding (ShakeValue) |
| 25 | +import Development.IDE.Types.Location |
| 26 | +import Development.IDE.Types.Options |
| 27 | +import qualified Language.LSP.Server as LSP |
| 28 | +import Language.LSP.Types |
| 29 | +import qualified Language.LSP.Types as LSP |
| 30 | +import System.Time.Extra |
| 31 | +import UnliftIO.Exception (bracket_) |
| 32 | + |
| 33 | +data ProgressEvent |
| 34 | + = KickStarted |
| 35 | + | KickCompleted |
| 36 | + |
| 37 | +data ProgressReporting = ProgressReporting |
| 38 | + { progressUpdate :: ProgressEvent -> IO () |
| 39 | + , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a |
| 40 | + , progressStop :: IO () |
| 41 | + } |
| 42 | + |
| 43 | +noProgressReporting :: IO ProgressReporting |
| 44 | +noProgressReporting = return $ ProgressReporting |
| 45 | + { progressUpdate = const $ pure () |
| 46 | + , inProgress = const id |
| 47 | + , progressStop = pure () |
| 48 | + } |
| 49 | + |
| 50 | +delayedProgressReporting |
| 51 | + :: Maybe (LSP.LanguageContextEnv c) |
| 52 | + -> ProgressReportingStyle |
| 53 | + -> IO ProgressReporting |
| 54 | +delayedProgressReporting lspEnv optProgressStyle = do |
| 55 | + inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int) |
| 56 | + mostRecentProgressEvent <- newTVarIO KickCompleted |
| 57 | + progressAsync <- async $ |
| 58 | + progressThread optProgressStyle mostRecentProgressEvent inProgressVar |
| 59 | + let progressUpdate = atomically . writeTVar mostRecentProgressEvent |
| 60 | + progressStop = cancel progressAsync |
| 61 | + inProgress :: NormalizedFilePath -> Action a -> Action a |
| 62 | + inProgress = withProgressVar inProgressVar |
| 63 | + 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 |
| 92 | + -- first sleep a bit, so we only show progress messages if it's going to take |
| 93 | + -- 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) |
| 157 | + |
| 158 | +mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () |
| 159 | +mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f |
| 160 | +mRunLspT Nothing _ = pure () |
| 161 | + |
| 162 | +mRunLspTCallback :: Monad m |
| 163 | + => Maybe (LSP.LanguageContextEnv c) |
| 164 | + -> (LSP.LspT c m a -> LSP.LspT c m a) |
| 165 | + -> m a |
| 166 | + -> m a |
| 167 | +mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) |
| 168 | +mRunLspTCallback Nothing _ g = g |
0 commit comments