1+ {-# LANGUAGE ScopedTypeVariables #-}
2+ {-# LANGUAGE TypeFamilies #-}
3+
14module Development.IDE.Core.ProgressReporting
25 ( ProgressEvent (.. ),
3- ProgressReporting (.. ),
4- noProgressReporting ,
6+ PerFileProgressReporting (.. ),
7+ ProgressReporting ,
8+ noPerFileProgressReporting ,
59 progressReporting ,
6- progressReportingOutsideState ,
10+ progressReportingNoTrace ,
711 -- utilities, reexported for use in Core.Shake
812 mRunLspT ,
913 mRunLspTCallback ,
1014 -- for tests
1115 recordProgress ,
1216 InProgressState (.. ),
17+ progressStop ,
18+ progressUpdate
1319 )
1420where
1521
@@ -34,46 +40,63 @@ import Language.LSP.Server (ProgressAmount (..),
3440 withProgress )
3541import qualified Language.LSP.Server as LSP
3642import qualified StmContainers.Map as STM
37- import UnliftIO (Async , MonadUnliftIO , async ,
38- bracket , cancel )
43+ import UnliftIO (Async , async , bracket , cancel )
3944
4045data ProgressEvent
4146 = ProgressNewStarted
4247 | ProgressCompleted
4348 | ProgressStarted
4449
45- data ProgressReporting m = ProgressReporting
46- { progressUpdate :: ProgressEvent -> m () ,
47- inProgress :: forall a . NormalizedFilePath -> m a -> m a ,
48- -- ^ see Note [ProgressReporting API and InProgressState]
49- progressStop :: IO ()
50+ data ProgressReporting = ProgressReporting
51+ { _progressUpdate :: ProgressEvent -> IO () ,
52+ _progressStop :: IO ()
5053 -- ^ we are using IO here because creating and stopping the `ProgressReporting`
5154 -- is different from how we use it.
5255 }
5356
57+ data PerFileProgressReporting = PerFileProgressReporting
58+ {
59+ inProgress :: forall a . NormalizedFilePath -> IO a -> IO a ,
60+ -- ^ see Note [ProgressReporting API and InProgressState]
61+ progressReportingInner :: ProgressReporting
62+ }
63+
64+ class ProgressReporter a where
65+ progressUpdate :: a -> ProgressEvent -> IO ()
66+ progressStop :: a -> IO ()
67+
68+ instance ProgressReporter ProgressReporting where
69+ progressUpdate = _progressUpdate
70+ progressStop = _progressStop
71+
72+ instance ProgressReporter PerFileProgressReporting where
73+ progressUpdate = _progressUpdate . progressReportingInner
74+ progressStop = _progressStop . progressReportingInner
75+
5476{- Note [ProgressReporting API and InProgressState]
5577~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5678The progress of tasks can be tracked in two ways:
5779
58- 1. `InProgressState `: This is an internal state that actively tracks the progress.
80+ 1. `ProgressReporting `: we have an internal state that actively tracks the progress.
5981 Changes to the progress are made directly to this state.
6082
61- 2. `InProgressStateOutSide `: This is an external state that tracks the progress.
83+ 2. `ProgressReporting `: there is an external state that tracks the progress.
6284 The external state is converted into an STM Int for the purpose of reporting progress.
6385
64- The `inProgress` function is only useful when we are using `InProgressState`.
65-
66- An alternative design could involve using GADTs to eliminate this discrepancy between
67- `InProgressState` and `InProgressStateOutSide`.
86+ The `inProgress` function is only useful when we are using `ProgressReporting`.
6887-}
6988
70- noProgressReporting :: (MonadUnliftIO m ) => IO ProgressReporting m )
71- noProgressReporting =
89+ noProgressReporting :: ProgressReporting
90+ noProgressReporting = ProgressReporting
91+ { _progressUpdate = const $ pure () ,
92+ _progressStop = pure ()
93+ }
94+ noPerFileProgressReporting :: IO PerFileProgressReporting
95+ noPerFileProgressReporting =
7296 return $
73- ProgressReporting
74- { progressUpdate = const $ pure () ,
75- inProgress = const id ,
76- progressStop = pure ()
97+ PerFileProgressReporting
98+ { inProgress = const id ,
99+ progressReportingInner = noProgressReporting
77100 }
78101
79102-- | State used in 'delayedProgressReporting'
@@ -106,29 +129,20 @@ data InProgressState
106129 doneVar :: TVar Int
107130 currentVar :: STM. MapNormalizedFilePath Int
108131 }
109- | InProgressStateOutSide
110- -- we transform the outside state into STM Int for progress reporting purposes
111- { -- | Number of files to do
112- todo :: STM Int
113- -- | Number of files done
114- done :: STM Int
115- }
116132
117133newInProgress :: IO InProgressState
118134newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM. newIO
119135
120136recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int -> IO ()
121- recordProgress InProgressStateOutSide {} _ _ = return ()
122137recordProgress InProgressState {.. } file shift = do
123138 (prev, new) <- atomicallyNamed " recordProgress" $ STM. focus alterPrevAndNew file currentVar
124- atomicallyNamed " recordProgress2" $ do
125- case (prev, new) of
126- (Nothing , 0 ) -> modifyTVar' doneVar (+ 1 ) >> modifyTVar' todoVar (+ 1 )
127- (Nothing , _) -> modifyTVar' todoVar (+ 1 )
128- (Just 0 , 0 ) -> pure ()
129- (Just 0 , _) -> modifyTVar' doneVar pred
130- (Just _, 0 ) -> modifyTVar' doneVar (+ 1 )
131- (Just _, _) -> pure ()
139+ atomicallyNamed " recordProgress2" $ case (prev, new) of
140+ (Nothing , 0 ) -> modifyTVar' doneVar (+ 1 ) >> modifyTVar' todoVar (+ 1 )
141+ (Nothing , _) -> modifyTVar' todoVar (+ 1 )
142+ (Just 0 , 0 ) -> pure ()
143+ (Just 0 , _) -> modifyTVar' doneVar pred
144+ (Just _, 0 ) -> modifyTVar' doneVar (+ 1 )
145+ (Just _, _) -> pure ()
132146 where
133147 alterPrevAndNew = do
134148 prev <- Focus. lookup
@@ -138,57 +152,49 @@ recordProgress InProgressState {..} file shift = do
138152 alter x = let x' = maybe (shift 0 ) shift x in Just x'
139153
140154
141- -- | `progressReporting` initiates a new progress reporting session.
142- -- It necessitates the active tracking of progress using the `inProgress` function.
143- -- Refer to Note [ProgressReporting API and InProgressState] for more details.
144- progressReporting ::
145- (MonadUnliftIO m , MonadIO m ) =>
146- Maybe LSP. LanguageContextEnvc ) ->
147- T. Text->
148- ProgressReportingStyle ->
149- IO ProgressReporting m )
150- progressReporting = progressReporting' newInProgress
151-
152- -- | `progressReportingOutsideState` initiates a new progress reporting session.
155+ -- | `progressReportingNoTrace` initiates a new progress reporting session.
153156-- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking.
154157-- Refer to Note [ProgressReporting API and InProgressState] for more details.
155- progressReportingOutsideState ::
156- (MonadUnliftIO m , MonadIO m ) =>
158+ progressReportingNoTrace ::
157159 STM Int ->
158160 STM Int ->
159161 Maybe LSP. LanguageContextEnvc ) ->
160162 T. Text->
161163 ProgressReportingStyle ->
162- IO ProgressReporting m )
163- progressReportingOutsideState todo done = progressReporting' (pure $ InProgressStateOutSide todo done)
164+ IO ProgressReporting
165+ progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting
166+ progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do
167+ progressState <- newVar NotStarted
168+ let _progressUpdate event = liftIO $ updateStateVar $ Event event
169+ _progressStop = updateStateVar StopProgress
170+ updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done)
171+ return ProgressReporting {.. }
164172
165- progressReporting' ::
166- (MonadUnliftIO m , MonadIO m ) =>
167- IO InProgressState ->
173+ -- | `progressReporting` initiates a new progress reporting session.
174+ -- It necessitates the active tracking of progress using the `inProgress` function.
175+ -- Refer to Note [ProgressReporting API and InProgressState] for more details.
176+ progressReporting ::
168177 Maybe LSP. LanguageContextEnvc ) ->
169178 T. Text->
170179 ProgressReportingStyle ->
171- IO ( ProgressReporting m )
172- progressReporting' _newState Nothing _title _optProgressStyle = noProgressReporting
173- progressReporting' newState (Just lspEnv) title optProgressStyle = do
174- inProgressState <- newState
175- progressState <- newVar NotStarted
176- let progressUpdate event = liftIO $ updateStateVar $ Event event
177- progressStop = updateStateVar StopProgress
178- updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState)
179- inProgress = updateStateForFile inProgressState
180- return ProgressReporting {.. }
180+ IO PerFileProgressReporting
181+ progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting
182+ progressReporting (Just lspEnv) title optProgressStyle = do
183+ inProgressState <- newInProgress
184+ progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState)
185+ (readTVar $ doneVar inProgressState) ( Just lspEnv) title optProgressStyle
186+ let
187+ inProgress :: NormalizedFilePath -> IO a -> IO a
188+ inProgress = updateStateForFile inProgressState
189+ return PerFileProgressReporting {.. }
181190 where
182- lspShakeProgressNew :: InProgressState -> IO ()
183- lspShakeProgressNew InProgressStateOutSide {.. } = progressCounter lspEnv title optProgressStyle todo done
184- lspShakeProgressNew InProgressState {.. } = progressCounter lspEnv title optProgressStyle (readTVar todoVar) (readTVar doneVar)
185191 updateStateForFile inProgress file = UnliftIO. bracket (liftIO $ f succ ) (const $ liftIO $ f pred ) . const
186192 where
187193 -- This functions are deliberately eta-expanded to avoid space leaks.
188194 -- Do not remove the eta-expansion without profiling a session with at
189195 -- least 1000 modifications.
190196
191- f shift = recordProgress inProgress file shift
197+ f = recordProgress inProgress file
192198
193199-- Kill this to complete the progress session
194200progressCounter ::
0 commit comments