Skip to content

Commit 8981601

Browse files
soulomoonsoulomoon
committed
swtich to general progress
1 parent c11f32b commit 8981601

File tree

4 files changed

+40
-90
lines changed

4 files changed

+40
-90
lines changed

‎ghcide/src/Development/IDE/Core/Compile.hs

+16-68
Original file line numberDiff line numberDiff line change
@@ -129,6 +129,7 @@ import GHC.Driver.Config.CoreToStg.Prep
129129
#if MIN_VERSION_ghc(9,7,0)
130130
import Data.Foldable (toList)
131131
import GHC.Unit.Module.Warnings
132+
import Development.IDE.Core.ProgressReporting (progressReporting, ProgressReporting (..))
132133
#else
133134
import Development.IDE.Core.FileStore (shareFilePath)
134135
#endif
@@ -898,6 +899,7 @@ indexHieFile se mod_summary srcPath !hash hf = do
898899
_ -> do
899900
-- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
900901
let !hf' = hf{hie_hs_src = mempty}
902+
-- todo, this is the real pending count
901903
modifyTVar' indexPending $ HashMap.insert srcPath hash
902904
writeTQueue indexQueue $ \withHieDb -> do
903905
-- We are now in the worker thread
@@ -911,69 +913,20 @@ indexHieFile se mod_summary srcPath !hash hf = do
911913
unless newerScheduled $ do
912914
-- Using bracket, so even if an exception happen during withHieDb call,
913915
-- the `post` (which clean the progress indicator) will still be called.
914-
bracket_ (pre optProgressStyle) post $
915-
withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')
916+
tok <- modifyVar indexProgressToken $ fmap (first Just . dupe) . \case
917+
Just x -> return x
918+
-- create a progressReport if we don't already have one
919+
Nothing -> do
920+
tt <- progressReporting (lspEnv se) "Indexing" optProgressStyle
921+
progressUpdate tt ProgressStarted
922+
return tt
923+
inProgress tok srcPath
924+
(withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf'))
925+
`finally` post
916926
where
917927
mod_location = ms_location mod_summary
918928
targetPath = Compat.ml_hie_file mod_location
919929
HieDbWriter{..} = hiedbWriter se
920-
921-
-- Get a progress token to report progress and update it for the current file
922-
pre style = do
923-
tok <- modifyVar indexProgressToken $ fmap dupe . \case
924-
x@(Just _) -> pure x
925-
-- Create a token if we don't already have one
926-
Nothing -> do
927-
case lspEnv se of
928-
Nothing -> pure Nothing
929-
Just env -> LSP.runLspT env $ do
930-
u <- LSP.ProgressToken . LSP.InR . T.pack . show . hashUnique <$> liftIO Unique.newUnique
931-
-- TODO: Wait for the progress create response to use the token
932-
_ <- LSP.sendRequest LSP.SMethod_WindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())
933-
LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams u $
934-
toJSON $ LSP.WorkDoneProgressBegin
935-
{ _kind = LSP.AString @"begin"
936-
, _title = "Indexing"
937-
, _cancellable = Nothing
938-
, _message = Nothing
939-
, _percentage = Nothing
940-
}
941-
pure (Just u)
942-
943-
(!done, !remaining) <- atomically $ do
944-
done <- readTVar indexCompleted
945-
remaining <- HashMap.size <$> readTVar indexPending
946-
pure (done, remaining)
947-
let
948-
progressFrac :: Double
949-
progressFrac = fromIntegral done / fromIntegral (done + remaining)
950-
progressPct :: LSP.UInt
951-
progressPct = floor $ 100 * progressFrac
952-
953-
whenJust (lspEnv se) $ \env -> whenJust tok $ \token -> LSP.runLspT env $
954-
LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $
955-
toJSON $
956-
case style of
957-
Percentage -> LSP.WorkDoneProgressReport
958-
{ _kind = LSP.AString @"report"
959-
, _cancellable = Nothing
960-
, _message = Nothing
961-
, _percentage = Just progressPct
962-
}
963-
Explicit -> LSP.WorkDoneProgressReport
964-
{ _kind = LSP.AString @"report"
965-
, _cancellable = Nothing
966-
, _message = Just $
967-
T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."
968-
, _percentage = Nothing
969-
}
970-
NoProgress -> LSP.WorkDoneProgressReport
971-
{ _kind = LSP.AString @"report"
972-
, _cancellable = Nothing
973-
, _message = Nothing
974-
, _percentage = Nothing
975-
}
976-
977930
-- Report the progress once we are done indexing this file
978931
post = do
979932
mdone <- atomically $ do
@@ -988,16 +941,11 @@ indexHieFile se mod_summary srcPath !hash hf = do
988941
when (coerce $ ideTesting se) $
989942
LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $
990943
toJSON $ fromNormalizedFilePath srcPath
991-
whenJust mdone $ \done ->
944+
whenJust mdone $ \_ ->
992945
modifyVar_ indexProgressToken $ \tok -> do
993-
whenJust (lspEnv se) $ \env -> LSP.runLspT env $
994-
whenJust tok $ \token ->
995-
LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $
996-
toJSON $
997-
LSP.WorkDoneProgressEnd
998-
{ _kind = LSP.AString @"end"
999-
, _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"
1000-
}
946+
case tok of
947+
Just token -> progressUpdate token ProgressCompleted
948+
Nothing -> return ()
1001949
-- We are done with the current indexing cycle, so destroy the token
1002950
pure Nothing
1003951

‎ghcide/src/Development/IDE/Core/OfInterest.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -141,7 +141,7 @@ kick = do
141141
toJSON $ map fromNormalizedFilePath files
142142

143143
signal (Proxy @"kick/start")
144-
liftIO $ progressUpdate progress KickStarted
144+
liftIO $ progressUpdate progress ProgressStarted
145145

146146
-- Update the exports map
147147
results <- uses GenerateCore files
@@ -152,7 +152,7 @@ kick = do
152152
let mguts = catMaybes results
153153
void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts)
154154

155-
liftIO $ progressUpdate progress KickCompleted
155+
liftIO $ progressUpdate progress ProgressCompleted
156156

157157
GarbageCollectVar var <- getIdeGlobalAction
158158
garbageCollectionScheduled <- liftIO $ readVar var

‎ghcide/src/Development/IDE/Core/ProgressReporting.hs

+19-17
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,6 @@ import Control.Monad.Trans.Class (lift)
2323
import Data.Functor (($>))
2424
import qualified Data.Text as T
2525
import Development.IDE.GHC.Orphans ()
26-
import Development.IDE.Graph hiding (ShakeValue)
2726
import Development.IDE.Types.Location
2827
import Development.IDE.Types.Options
2928
import qualified Focus
@@ -33,19 +32,20 @@ import Language.LSP.Server (ProgressAmount (..),
3332
withProgress)
3433
import qualified Language.LSP.Server as LSP
3534
import qualified StmContainers.Map as STM
36-
import UnliftIO (Async, async, cancel)
35+
import UnliftIO (Async, MonadUnliftIO, async,
36+
bracket, cancel)
3737

3838
data ProgressEvent
39-
= KickStarted
40-
| KickCompleted
39+
= ProgressStarted
40+
| ProgressCompleted
4141

42-
data ProgressReporting = ProgressReporting
42+
data ProgressReporting m = ProgressReporting
4343
{ progressUpdate :: ProgressEvent -> IO ()
44-
, inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
44+
, inProgress :: forall a. NormalizedFilePath -> m a -> m a
4545
, progressStop :: IO ()
4646
}
4747

48-
noProgressReporting :: IO ProgressReporting
48+
noProgressReporting :: IO (ProgressReporting m)
4949
noProgressReporting = return $ ProgressReporting
5050
{ progressUpdate = const $ pure ()
5151
, inProgress = const id
@@ -63,10 +63,10 @@ data Transition = Event ProgressEvent | StopProgress
6363

6464
updateState :: IO () -> Transition -> State -> IO State
6565
updateState _ _ Stopped = pure Stopped
66-
updateState start (Event KickStarted) NotStarted = Running <$> async start
67-
updateState start (Event KickStarted) (Running job) = cancel job >> Running <$> async start
68-
updateState _ (Event KickCompleted) (Running job) = cancel job $> NotStarted
69-
updateState _ (Event KickCompleted) st = pure st
66+
updateState start (Event ProgressStarted) NotStarted = Running <$> async start
67+
updateState start (Event ProgressStarted) (Running job) = cancel job >> Running <$> async start
68+
updateState _ (Event ProgressCompleted) (Running job) = cancel job $> NotStarted
69+
updateState _ (Event ProgressCompleted) st = pure st
7070
updateState _ StopProgress (Running job) = cancel job $> Stopped
7171
updateState _ StopProgress st = pure st
7272

@@ -100,11 +100,13 @@ recordProgress InProgressState{..} file shift = do
100100
alter x = let x' = maybe (shift 0) shift x in Just x'
101101

102102
progressReporting
103-
:: Maybe (LSP.LanguageContextEnv c)
103+
:: (MonadUnliftIO m, MonadIO m)
104+
=> Maybe (LSP.LanguageContextEnv c)
105+
-> T.Text
104106
-> ProgressReportingStyle
105-
-> IO ProgressReporting
106-
progressReporting Nothing _optProgressStyle = noProgressReporting
107-
progressReporting (Just lspEnv) optProgressStyle = do
107+
-> IO (ProgressReporting m)
108+
progressReporting Nothing _title _optProgressStyle = noProgressReporting
109+
progressReporting (Just lspEnv) title optProgressStyle = do
108110
inProgressState <- newInProgress
109111
progressState <- newVar NotStarted
110112
let progressUpdate event = updateStateVar $ Event event
@@ -115,7 +117,7 @@ progressReporting (Just lspEnv) optProgressStyle = do
115117
where
116118
lspShakeProgressNew :: InProgressState -> IO ()
117119
lspShakeProgressNew InProgressState{..} =
118-
LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0
120+
LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0
119121
where
120122
loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound
121123
loop update prevPct = do
@@ -131,7 +133,7 @@ progressReporting (Just lspEnv) optProgressStyle = do
131133

132134
update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))
133135
loop update nextPct
134-
updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const
136+
updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const
135137
-- This functions are deliberately eta-expanded to avoid space leaks.
136138
-- Do not remove the eta-expansion without profiling a session with at
137139
-- least 1000 modifications.

‎ghcide/src/Development/IDE/Core/Shake.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -255,7 +255,7 @@ data HieDbWriter
255255
{ indexQueue :: IndexQueue
256256
, indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing
257257
, indexCompleted :: TVar Int -- ^ to report progress
258-
, indexProgressToken :: Var (Maybe LSP.ProgressToken)
258+
, indexProgressToken :: Var (Maybe (ProgressReporting IO))
259259
-- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock
260260
}
261261

@@ -306,7 +306,7 @@ data ShakeExtras = ShakeExtras
306306
-- positions in a version of that document to positions in the latest version
307307
-- First mapping is delta from previous version and second one is an
308308
-- accumulation to the current version.
309-
,progress :: ProgressReporting
309+
,progress :: ProgressReporting Action
310310
,ideTesting :: IdeTesting
311311
-- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
312312
,restartShakeSession
@@ -710,7 +710,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
710710

711711
progress <-
712712
if reportProgress
713-
then progressReporting lspEnv optProgressStyle
713+
then progressReporting lspEnv "Processing" optProgressStyle
714714
else noProgressReporting
715715
actionQueue <- newQueue
716716

0 commit comments

Comments
 (0)