|
| 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.Strict |
| 15 | +import Control.Monad.Extra |
| 16 | +import Control.Monad.IO.Class |
| 17 | +import Control.Monad.Trans.Class (lift) |
| 18 | +import Data.Foldable (for_) |
| 19 | +import Data.Functor (($>)) |
| 20 | +import qualified Data.HashMap.Strict as HMap |
| 21 | +import Data.Maybe (isJust) |
| 22 | +import qualified Data.Text as T |
| 23 | +import Data.Unique |
| 24 | +import Development.IDE.GHC.Orphans () |
| 25 | +import Development.IDE.Graph hiding (ShakeValue) |
| 26 | +import Development.IDE.Types.Location |
| 27 | +import Development.IDE.Types.Options |
| 28 | +import qualified Language.LSP.Server as LSP |
| 29 | +import Language.LSP.Types |
| 30 | +import qualified Language.LSP.Types as LSP |
| 31 | +import System.Time.Extra |
| 32 | +import UnliftIO.Exception (bracket_) |
| 33 | + |
| 34 | +data ProgressEvent |
| 35 | + = KickStarted |
| 36 | + | KickCompleted |
| 37 | + |
| 38 | +data ProgressReporting = ProgressReporting |
| 39 | + { progressUpdate :: ProgressEvent -> IO () |
| 40 | + , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a |
| 41 | + , progressStop :: IO () |
| 42 | + } |
| 43 | + |
| 44 | +noProgressReporting :: IO ProgressReporting |
| 45 | +noProgressReporting = return $ ProgressReporting |
| 46 | + { progressUpdate = const $ pure () |
| 47 | + , inProgress = const id |
| 48 | + , progressStop = pure () |
| 49 | + } |
| 50 | + |
| 51 | +-- | State used in 'delayedProgressReporting' |
| 52 | +data State |
| 53 | + = NotStarted |
| 54 | + | Stopped |
| 55 | + | Running (Async ()) |
| 56 | + |
| 57 | +-- | State transitions used in 'delayedProgressReporting' |
| 58 | +data Transition = Event ProgressEvent | StopProgress |
| 59 | + |
| 60 | +updateState :: IO () -> Transition -> State -> IO State |
| 61 | +updateState _ _ Stopped = pure Stopped |
| 62 | +updateState start (Event KickStarted) NotStarted = Running <$> async start |
| 63 | +updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> async start |
| 64 | +updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted |
| 65 | +updateState _ (Event KickCompleted) st = pure st |
| 66 | +updateState _ StopProgress (Running a) = cancel a $> Stopped |
| 67 | +updateState _ StopProgress st = pure st |
| 68 | + |
| 69 | +-- | Data structure to track progress across the project |
| 70 | +data InProgress = InProgress |
| 71 | + { todo :: !Int -- ^ Number of files to do |
| 72 | + , done :: !Int -- ^ Number of files done |
| 73 | + , current :: !(HMap.HashMap NormalizedFilePath Int) |
| 74 | + } |
| 75 | + |
| 76 | +recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress |
| 77 | +recordProgress file shift InProgress{..} = case HMap.alterF alter file current of |
| 78 | + ((prev, new), m') -> |
| 79 | + let todo' = if isJust prev then todo else todo + 1 |
| 80 | + done' = if new == 0 then done+1 else done |
| 81 | + in InProgress todo' done' m' |
| 82 | + where |
| 83 | + alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x') |
| 84 | + |
| 85 | +-- | A 'ProgressReporting' that enqueues Begin and End notifications in a new |
| 86 | +-- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives |
| 87 | +-- before the end of the grace period). |
| 88 | +delayedProgressReporting |
| 89 | + :: Seconds -- ^ Grace period before starting |
| 90 | + -> Seconds -- ^ sampling delay |
| 91 | + -> Maybe (LSP.LanguageContextEnv c) |
| 92 | + -> ProgressReportingStyle |
| 93 | + -> IO ProgressReporting |
| 94 | +delayedProgressReporting before after lspEnv optProgressStyle = do |
| 95 | + inProgressVar <- newVar $ InProgress 0 0 mempty |
| 96 | + progressState <- newVar NotStarted |
| 97 | + let progressUpdate event = updateStateVar $ Event event |
| 98 | + progressStop = updateStateVar StopProgress |
| 99 | + updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) |
| 100 | + |
| 101 | + inProgress :: NormalizedFilePath -> Action a -> Action a |
| 102 | + inProgress = withProgressVar inProgressVar |
| 103 | + return ProgressReporting{..} |
| 104 | + where |
| 105 | + lspShakeProgress inProgress = do |
| 106 | + -- first sleep a bit, so we only show progress messages if it's going to take |
| 107 | + -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) |
| 108 | + liftIO $ sleep before |
| 109 | + u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique |
| 110 | + |
| 111 | + b <- liftIO newBarrier |
| 112 | + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate |
| 113 | + LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b |
| 114 | + ready <- liftIO $ waitBarrier b |
| 115 | + |
| 116 | + for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) |
| 117 | + where |
| 118 | + start id = LSP.sendNotification LSP.SProgress $ |
| 119 | + LSP.ProgressParams |
| 120 | + { _token = id |
| 121 | + , _value = LSP.Begin $ WorkDoneProgressBeginParams |
| 122 | + { _title = "Processing" |
| 123 | + , _cancellable = Nothing |
| 124 | + , _message = Nothing |
| 125 | + , _percentage = Nothing |
| 126 | + } |
| 127 | + } |
| 128 | + stop id = LSP.sendNotification LSP.SProgress |
| 129 | + LSP.ProgressParams |
| 130 | + { _token = id |
| 131 | + , _value = LSP.End WorkDoneProgressEndParams |
| 132 | + { _message = Nothing |
| 133 | + } |
| 134 | + } |
| 135 | + loop _ _ | optProgressStyle == NoProgress = |
| 136 | + forever $ liftIO $ threadDelay maxBound |
| 137 | + loop id prev = do |
| 138 | + InProgress{..} <- liftIO $ readVar inProgress |
| 139 | + liftIO $ sleep after |
| 140 | + if todo == 0 then loop id 0 else do |
| 141 | + let next = 100 * fromIntegral done / fromIntegral todo |
| 142 | + when (next /= prev) $ |
| 143 | + LSP.sendNotification LSP.SProgress $ |
| 144 | + LSP.ProgressParams |
| 145 | + { _token = id |
| 146 | + , _value = LSP.Report $ case optProgressStyle of |
| 147 | + Explicit -> LSP.WorkDoneProgressReportParams |
| 148 | + { _cancellable = Nothing |
| 149 | + , _message = Just $ T.pack $ show done <> "/" <> show todo |
| 150 | + , _percentage = Nothing |
| 151 | + } |
| 152 | + Percentage -> LSP.WorkDoneProgressReportParams |
| 153 | + { _cancellable = Nothing |
| 154 | + , _message = Nothing |
| 155 | + , _percentage = Just next |
| 156 | + } |
| 157 | + NoProgress -> error "unreachable" |
| 158 | + } |
| 159 | + loop id next |
| 160 | + |
| 161 | + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const |
| 162 | + -- This functions are deliberately eta-expanded to avoid space leaks. |
| 163 | + -- Do not remove the eta-expansion without profiling a session with at |
| 164 | + -- least 1000 modifications. |
| 165 | + where |
| 166 | + f shift = modifyVar' var $ recordProgress file shift |
| 167 | + |
| 168 | +mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () |
| 169 | +mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f |
| 170 | +mRunLspT Nothing _ = pure () |
| 171 | + |
| 172 | +mRunLspTCallback :: Monad m |
| 173 | + => Maybe (LSP.LanguageContextEnv c) |
| 174 | + -> (LSP.LspT c m a -> LSP.LspT c m a) |
| 175 | + -> m a |
| 176 | + -> m a |
| 177 | +mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) |
| 178 | +mRunLspTCallback Nothing _ g = g |
0 commit comments