Skip to content

Commit aeef1ea

Browse files
soulomoonsoulomoon
committed
initialize and pass progress chan
1 parent e78c8f4 commit aeef1ea

File tree

5 files changed

+25
-17
lines changed

5 files changed

+25
-17
lines changed

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -379,7 +379,7 @@ makeWithHieDbRetryable recorder rng hieDb f =
379379
-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
380380
-- by a worker thread using a dedicated database connection.
381381
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
382-
runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
382+
runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> TQueue (IO ()) -> IO ()) -> IO ()
383383
runWithDb recorder fp k = do
384384
-- use non-deterministic seed because maybe multiple HLS start at same time
385385
-- and send bursts of requests
@@ -399,9 +399,11 @@ runWithDb recorder fp k = do
399399
withWriteDbRetryable initConn
400400

401401
chan <- newTQueueIO
402+
progressChan <- newTQueueIO
402403

403404
withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do
404-
withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan)
405+
withAsync (progressThread progressChan) $ \_ -> do
406+
withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan progressChan)
405407
where
406408
progressThread :: TQueue (IO ()) -> IO ()
407409
progressThread chan = forever $ join $ atomically $ readTQueue chan

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Ide.Plugin.Config
3131
import qualified Language.LSP.Protocol.Types as LSP
3232
import qualified Language.LSP.Server as LSP
3333

34+
import Control.Concurrent.STM (TQueue)
3435
import Control.Monad
3536
import qualified Development.IDE.Core.FileExists as FileExists
3637
import qualified Development.IDE.Core.OfInterest as OfInterest
@@ -66,9 +67,10 @@ initialise :: Recorder (WithPriority Log)
6667
-> IdeOptions
6768
-> WithHieDb
6869
-> IndexQueue
70+
-> TQueue (IO ())
6971
-> Monitoring
7072
-> IO IdeState
71-
initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do
73+
initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan progressChan metrics = do
7274
shakeProfiling <- do
7375
let fromConf = optShakeProfiling options
7476
fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
@@ -84,6 +86,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
8486
(optTesting options)
8587
withHieDb
8688
hiedbChan
89+
progressChan
8790
(optShakeOptions options)
8891
metrics
8992
$ do

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -624,14 +624,15 @@ shakeOpen :: Recorder (WithPriority Log)
624624
-> IdeTesting
625625
-> WithHieDb
626626
-> IndexQueue
627+
-> TQueue (IO ())
627628
-> ShakeOptions
628629
-> Monitoring
629630
-> Rules ()
630631
-> IO IdeState
631632
shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
632633
shakeProfileDir (IdeReportProgress reportProgress)
633634
ideTesting@(IdeTesting testing)
634-
withHieDb indexQueue opts monitoring rules = mdo
635+
withHieDb indexQueue progressChan opts monitoring rules = mdo
635636

636637
#if MIN_VERSION_ghc(9,3,0)
637638
ideNc <- initNameCache 'r' knownKeyNames
@@ -654,7 +655,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
654655
indexCompleted <- newTVarIO 0
655656
semanticTokensId <- newTVarIO 0
656657
indexProgressToken <- newVar Nothing
657-
indexProgressThread <- newTQueueIO
658+
let indexProgressThread = progressChan
658659
let hiedbWriter = HieDbWriter{..}
659660
exportsMap <- newTVarIO mempty
660661
-- lazily initialize the exports map with the contents of the hiedb

‎ghcide/src/Development/IDE/LSP/LanguageServer.hs

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -128,7 +128,7 @@ setupLSP ::
128128
Recorder (WithPriority Log)
129129
-> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
130130
-> LSP.Handlers (ServerM config)
131-
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
131+
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> TQueue (IO ()) -> IO IdeState)
132132
-> MVar ()
133133
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
134134
LSP.Handlers (ServerM config),
@@ -186,7 +186,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
186186
handleInit
187187
:: Recorder (WithPriority Log)
188188
-> (FilePath -> IO FilePath)
189-
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
189+
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> TQueue (IO ()) -> IO IdeState)
190190
-> MVar ()
191191
-> IO ()
192192
-> (SomeLspId -> IO ())
@@ -228,8 +228,8 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
228228
exceptionInHandler e
229229
k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing
230230
_ <- flip forkFinally handleServerException $ do
231-
untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do
232-
putMVar dbMVar (WithHieDbShield withHieDb',hieChan')
231+
untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' progressChan' -> do
232+
putMVar dbMVar (WithHieDbShield withHieDb',hieChan', progressChan')
233233
forever $ do
234234
msg <- readChan clientMsgChan
235235
-- We dispatch notifications synchronously and requests asynchronously
@@ -239,8 +239,8 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
239239
ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
240240
logWith recorder Info LogReactorThreadStopped
241241

242-
(WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar
243-
ide <- getIdeState env root withHieDb hieChan
242+
(WithHieDbShield withHieDb,hieChan, progressChan) <- takeMVar dbMVar
243+
ide <- getIdeState env root withHieDb hieChan progressChan
244244
registerIdeConfiguration (shakeExtras ide) initConfig
245245
pure $ Right (env,ide)
246246

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module Development.IDE.Main
1414
import Control.Concurrent.Extra (withNumCapabilities)
1515
import Control.Concurrent.MVar (newEmptyMVar,
1616
putMVar, tryReadMVar)
17+
import Control.Concurrent.STM (TQueue)
1718
import Control.Concurrent.STM.Stats (dumpSTMStats)
1819
import Control.Exception.Safe (SomeException,
1920
catchAny,
@@ -308,8 +309,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
308309
logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)
309310

310311
ideStateVar <- newEmptyMVar
311-
let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
312-
getIdeState env rootPath withHieDb hieChan = do
312+
let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> TQueue (IO ()) -> IO IdeState
313+
getIdeState env rootPath withHieDb hieChan progressChan = do
313314
traverse_ IO.setCurrentDirectory rootPath
314315
t <- ioT
315316
logWith recorder Info $ LogLspStartDuration t
@@ -348,6 +349,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
348349
ideOptions
349350
withHieDb
350351
hieChan
352+
progressChan
351353
monitoring
352354
putMVar ideStateVar ide
353355
pure ide
@@ -371,7 +373,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
371373
Check argFiles -> do
372374
dir <- maybe IO.getCurrentDirectory return argsProjectRoot
373375
dbLoc <- getHieDbLoc dir
374-
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
376+
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan proChan -> do
375377
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
376378
hSetEncoding stdout utf8
377379
hSetEncoding stderr utf8
@@ -399,7 +401,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
399401
, optCheckProject = pure False
400402
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
401403
}
402-
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
404+
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan proChan mempty
403405
shakeSessionInit (cmapWithPrio LogShake recorder) ide
404406
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
405407

@@ -429,15 +431,15 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
429431
Custom (IdeCommand c) -> do
430432
root <- maybe IO.getCurrentDirectory return argsProjectRoot
431433
dbLoc <- getHieDbLoc root
432-
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
434+
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan proChan -> do
433435
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."
434436
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
435437
ideOptions = def_options
436438
{ optCheckParents = pure NeverCheck
437439
, optCheckProject = pure False
438440
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
439441
}
440-
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
442+
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan proChan mempty
441443
shakeSessionInit (cmapWithPrio LogShake recorder) ide
442444
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
443445
c ide

0 commit comments

Comments
 (0)