mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Unify critical session running in hls (#4256)
* add thread to do shake restart * run session loader in thread --------- Co-authored-by: Michael Peyton Jones <me@michaelpj.com>
This commit is contained in:
parent
75634393d5
commit
82da33707f
@ -148,6 +148,7 @@ library
|
||||
Development.IDE.Core.Shake
|
||||
Development.IDE.Core.Tracing
|
||||
Development.IDE.Core.UseStale
|
||||
Development.IDE.Core.WorkerThread
|
||||
Development.IDE.GHC.Compat
|
||||
Development.IDE.GHC.Compat.Core
|
||||
Development.IDE.GHC.Compat.CmdLine
|
||||
|
@ -7,21 +7,19 @@ The logic for setting up a ghcide session by tapping into hie-bios.
|
||||
module Development.IDE.Session
|
||||
(SessionLoadingOptions(..)
|
||||
,CacheDirs(..)
|
||||
,loadSession
|
||||
,loadSessionWithOptions
|
||||
,setInitialDynFlags
|
||||
,getHieDbLoc
|
||||
,runWithDb
|
||||
,retryOnSqliteBusy
|
||||
,retryOnException
|
||||
,Log(..)
|
||||
,runWithDb
|
||||
) where
|
||||
|
||||
-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
|
||||
-- the real GHC library and the types are incompatible. Furthermore, when
|
||||
-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.Strict
|
||||
import Control.Exception.Safe as Safe
|
||||
import Control.Monad
|
||||
@ -100,14 +98,19 @@ import Control.Concurrent.STM.TQueue
|
||||
import Control.DeepSeq
|
||||
import Control.Exception (evaluate)
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Monad.Trans.Cont (ContT (ContT, runContT))
|
||||
import Data.Foldable (for_)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as Set
|
||||
import Database.SQLite.Simple
|
||||
import Development.IDE.Core.Tracing (withTrace)
|
||||
import Development.IDE.Core.WorkerThread (awaitRunInThread,
|
||||
withWorkerQueue)
|
||||
import Development.IDE.Session.Diagnostics (renderCradleError)
|
||||
import Development.IDE.Types.Shake (WithHieDb, toNoFileKey)
|
||||
import Development.IDE.Types.Shake (WithHieDb,
|
||||
WithHieDbShield (..),
|
||||
toNoFileKey)
|
||||
import HieDb.Create
|
||||
import HieDb.Types
|
||||
import HieDb.Utils
|
||||
@ -375,8 +378,10 @@ makeWithHieDbRetryable recorder rng hieDb f =
|
||||
-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
|
||||
-- by a worker thread using a dedicated database connection.
|
||||
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
|
||||
runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
|
||||
runWithDb recorder fp k = do
|
||||
--
|
||||
-- Also see Note [Serializing runs in separate thread]
|
||||
runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue)
|
||||
runWithDb recorder fp = ContT $ \k -> do
|
||||
-- use non-deterministic seed because maybe multiple HLS start at same time
|
||||
-- and send bursts of requests
|
||||
rng <- Random.newStdGen
|
||||
@ -394,18 +399,15 @@ runWithDb recorder fp k = do
|
||||
withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb
|
||||
withWriteDbRetryable initConn
|
||||
|
||||
chan <- newTQueueIO
|
||||
|
||||
withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do
|
||||
withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan)
|
||||
-- Clear the index of any files that might have been deleted since the last run
|
||||
_ <- withWriteDbRetryable deleteMissingRealFiles
|
||||
_ <- withWriteDbRetryable garbageCollectTypeNames
|
||||
|
||||
runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan ->
|
||||
withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
|
||||
where
|
||||
writerThread :: WithHieDb -> IndexQueue -> IO ()
|
||||
writerThread withHieDbRetryable chan = do
|
||||
-- Clear the index of any files that might have been deleted since the last run
|
||||
_ <- withHieDbRetryable deleteMissingRealFiles
|
||||
_ <- withHieDbRetryable garbageCollectTypeNames
|
||||
forever $ do
|
||||
l <- atomically $ readTQueue chan
|
||||
writer withHieDbRetryable l = do
|
||||
-- TODO: probably should let exceptions be caught/logged/handled by top level handler
|
||||
l withHieDbRetryable
|
||||
`Safe.catch` \e@SQLError{} -> do
|
||||
@ -435,11 +437,9 @@ getHieDbLoc dir = do
|
||||
-- This is the key function which implements multi-component support. All
|
||||
-- components mapping to the same hie.yaml file are mapped to the same
|
||||
-- HscEnv which is updated as new components are discovered.
|
||||
loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession)
|
||||
loadSession recorder = loadSessionWithOptions recorder def
|
||||
|
||||
loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
|
||||
loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
|
||||
loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession)
|
||||
loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
|
||||
let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]
|
||||
cradle_files <- newIORef []
|
||||
-- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
|
||||
@ -464,9 +464,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
|
||||
let res' = toAbsolutePath <$> res
|
||||
return $ normalise <$> res'
|
||||
|
||||
dummyAs <- async $ return (error "Uninitialised")
|
||||
runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
|
||||
|
||||
return $ do
|
||||
clientConfig <- getClientConfigAction
|
||||
extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
|
||||
@ -739,12 +736,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
|
||||
return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
|
||||
|
||||
returnWithVersion $ \file -> do
|
||||
opts <- join $ mask_ $ modifyVar runningCradle $ \as -> do
|
||||
-- If the cradle is not finished, then wait for it to finish.
|
||||
void $ wait as
|
||||
asyncRes <- async $ getOptions file
|
||||
return (asyncRes, wait asyncRes)
|
||||
pure opts
|
||||
-- see Note [Serializing runs in separate thread]
|
||||
awaitRunInThread que $ getOptions file
|
||||
|
||||
-- | Run the specific cradle on a specific FilePath via hie-bios.
|
||||
-- This then builds dependencies or whatever based on the cradle, gets the
|
||||
|
@ -53,6 +53,7 @@ instance Pretty Log where
|
||||
LogOfInterest msg -> pretty msg
|
||||
LogFileExists msg -> pretty msg
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Exposed API
|
||||
|
||||
@ -65,7 +66,7 @@ initialise :: Recorder (WithPriority Log)
|
||||
-> Debouncer LSP.NormalizedUri
|
||||
-> IdeOptions
|
||||
-> WithHieDb
|
||||
-> IndexQueue
|
||||
-> ThreadQueue
|
||||
-> Monitoring
|
||||
-> FilePath -- ^ Root directory see Note [Root Directory]
|
||||
-> IO IdeState
|
||||
|
@ -73,6 +73,7 @@ module Development.IDE.Core.Shake(
|
||||
garbageCollectDirtyKeysOlderThan,
|
||||
Log(..),
|
||||
VFSModified(..), getClientConfigAction,
|
||||
ThreadQueue(..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
@ -123,6 +124,7 @@ import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Core.ProgressReporting
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Core.Tracing
|
||||
import Development.IDE.Core.WorkerThread
|
||||
import Development.IDE.GHC.Compat (NameCache,
|
||||
initNameCache,
|
||||
knownKeyNames)
|
||||
@ -262,6 +264,12 @@ data HieDbWriter
|
||||
-- with (currently) retry functionality
|
||||
type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
|
||||
|
||||
data ThreadQueue = ThreadQueue {
|
||||
tIndexQueue :: IndexQueue
|
||||
, tRestartQueue :: TQueue (IO ())
|
||||
, tLoaderQueue :: TQueue (IO ())
|
||||
}
|
||||
|
||||
-- Note [Semantic Tokens Cache Location]
|
||||
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
-- storing semantic tokens cache for each file in shakeExtras might
|
||||
@ -334,6 +342,10 @@ data ShakeExtras = ShakeExtras
|
||||
-- ^ Default HLS config, only relevant if the client does not provide any Config
|
||||
, dirtyKeys :: TVar KeySet
|
||||
-- ^ Set of dirty rule keys since the last Shake run
|
||||
, restartQueue :: TQueue (IO ())
|
||||
-- ^ Queue of restart actions to be run.
|
||||
, loaderQueue :: TQueue (IO ())
|
||||
-- ^ Queue of loader actions to be run.
|
||||
}
|
||||
|
||||
type WithProgressFunc = forall a.
|
||||
@ -648,7 +660,7 @@ shakeOpen :: Recorder (WithPriority Log)
|
||||
-> IdeReportProgress
|
||||
-> IdeTesting
|
||||
-> WithHieDb
|
||||
-> IndexQueue
|
||||
-> ThreadQueue
|
||||
-> ShakeOptions
|
||||
-> Monitoring
|
||||
-> Rules ()
|
||||
@ -658,8 +670,12 @@ shakeOpen :: Recorder (WithPriority Log)
|
||||
-> IO IdeState
|
||||
shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
|
||||
shakeProfileDir (IdeReportProgress reportProgress)
|
||||
ideTesting@(IdeTesting testing)
|
||||
withHieDb indexQueue opts monitoring rules rootDir = mdo
|
||||
ideTesting
|
||||
withHieDb threadQueue opts monitoring rules rootDir = mdo
|
||||
-- see Note [Serializing runs in separate thread]
|
||||
let indexQueue = tIndexQueue threadQueue
|
||||
restartQueue = tRestartQueue threadQueue
|
||||
loaderQueue = tLoaderQueue threadQueue
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
ideNc <- initNameCache 'r' knownKeyNames
|
||||
@ -784,31 +800,33 @@ delayedAction a = do
|
||||
extras <- ask
|
||||
liftIO $ shakeEnqueue extras a
|
||||
|
||||
|
||||
-- | Restart the current 'ShakeSession' with the given system actions.
|
||||
-- Any actions running in the current session will be aborted,
|
||||
-- but actions added via 'shakeEnqueue' will be requeued.
|
||||
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
|
||||
shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
|
||||
withMVar'
|
||||
shakeSession
|
||||
(\runner -> do
|
||||
(stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
|
||||
keys <- ioActionBetweenShakeSession
|
||||
-- it is every important to update the dirty keys after we enter the critical section
|
||||
-- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
|
||||
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
|
||||
res <- shakeDatabaseProfile shakeDb
|
||||
backlog <- readTVarIO $ dirtyKeys shakeExtras
|
||||
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
|
||||
void $ awaitRunInThread (restartQueue shakeExtras) $ do
|
||||
withMVar'
|
||||
shakeSession
|
||||
(\runner -> do
|
||||
(stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
|
||||
keys <- ioActionBetweenShakeSession
|
||||
-- it is every important to update the dirty keys after we enter the critical section
|
||||
-- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
|
||||
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
|
||||
res <- shakeDatabaseProfile shakeDb
|
||||
backlog <- readTVarIO $ dirtyKeys shakeExtras
|
||||
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
|
||||
|
||||
-- this log is required by tests
|
||||
logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res
|
||||
)
|
||||
-- It is crucial to be masked here, otherwise we can get killed
|
||||
-- between spawning the new thread and updating shakeSession.
|
||||
-- See https://github.com/haskell/ghcide/issues/79
|
||||
(\() -> do
|
||||
(,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason)
|
||||
-- this log is required by tests
|
||||
logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res
|
||||
)
|
||||
-- It is crucial to be masked here, otherwise we can get killed
|
||||
-- between spawning the new thread and updating shakeSession.
|
||||
-- See https://github.com/haskell/ghcide/issues/79
|
||||
(\() -> do
|
||||
(,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason)
|
||||
where
|
||||
logErrorAfter :: Seconds -> IO () -> IO ()
|
||||
logErrorAfter seconds action = flip withAsync (const action) $ do
|
||||
|
54
ghcide/src/Development/IDE/Core/WorkerThread.hs
Normal file
54
ghcide/src/Development/IDE/Core/WorkerThread.hs
Normal file
@ -0,0 +1,54 @@
|
||||
{-
|
||||
Module : Development.IDE.Core.WorkerThread
|
||||
Author : @soulomoon
|
||||
SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
Description : This module provides an API for managing worker threads in the IDE.
|
||||
see Note [Serializing runs in separate thread]
|
||||
-}
|
||||
module Development.IDE.Core.WorkerThread
|
||||
(withWorkerQueue, awaitRunInThread)
|
||||
where
|
||||
|
||||
import Control.Concurrent.Async (withAsync)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.Strict (newBarrier, signalBarrier,
|
||||
waitBarrier)
|
||||
import Control.Monad (forever)
|
||||
import Control.Monad.Cont (ContT (ContT))
|
||||
|
||||
{-
|
||||
Note [Serializing runs in separate thread]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
We often want to take long-running actions using some resource that cannot be shared.
|
||||
In this instance it is useful to have a queue of jobs to run using the resource.
|
||||
Like the db writes, session loading in session loader, shake session restarts.
|
||||
|
||||
Originally we used various ways to implement this, but it was hard to maintain and error prone.
|
||||
Moreover, we can not stop these threads uniformly when we are shutting down the server.
|
||||
-}
|
||||
|
||||
-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker
|
||||
-- thread which polls the queue for requests and runs the given worker
|
||||
-- function on them.
|
||||
withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t)
|
||||
withWorkerQueue workerAction = ContT $ \mainAction -> do
|
||||
q <- newTQueueIO
|
||||
withAsync (writerThread q) $ \_ -> mainAction q
|
||||
where
|
||||
writerThread q =
|
||||
forever $ do
|
||||
l <- atomically $ readTQueue q
|
||||
workerAction l
|
||||
|
||||
-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,
|
||||
-- and then blocks until the result is computed.
|
||||
awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result
|
||||
awaitRunInThread q act = do
|
||||
-- Take an action from TQueue, run it and
|
||||
-- use barrier to wait for the result
|
||||
barrier <- newBarrier
|
||||
atomically $ writeTQueue q $ do
|
||||
res <- act
|
||||
signalBarrier barrier res
|
||||
waitBarrier barrier
|
@ -1,15 +1,16 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
|
||||
-- This version removes the daml: handling
|
||||
module Development.IDE.LSP.LanguageServer
|
||||
( runLanguageServer
|
||||
, setupLSP
|
||||
, Log(..)
|
||||
, ThreadQueue
|
||||
, runWithWorkerThreads
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
@ -34,11 +35,14 @@ import UnliftIO.Exception
|
||||
|
||||
import qualified Colog.Core as Colog
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Monad.Trans.Cont (evalContT)
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.Shake hiding (Log)
|
||||
import Development.IDE.Core.Tracing
|
||||
import Development.IDE.Core.WorkerThread (withWorkerQueue)
|
||||
import qualified Development.IDE.Session as Session
|
||||
import Development.IDE.Types.Shake (WithHieDb)
|
||||
import Development.IDE.Types.Shake (WithHieDb,
|
||||
WithHieDbShield (..))
|
||||
import Ide.Logger
|
||||
import Language.LSP.Server (LanguageContextEnv,
|
||||
LspServerLog,
|
||||
@ -77,8 +81,6 @@ instance Pretty Log where
|
||||
LogLspServer msg -> pretty msg
|
||||
LogServerShutdownMessage -> "Received shutdown message"
|
||||
|
||||
-- used to smuggle RankNType WithHieDb through dbMVar
|
||||
newtype WithHieDbShield = WithHieDbShield WithHieDb
|
||||
|
||||
runLanguageServer
|
||||
:: forall config a m. (Show config)
|
||||
@ -130,7 +132,7 @@ setupLSP ::
|
||||
-> FilePath -- ^ root directory, see Note [Root Directory]
|
||||
-> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
|
||||
-> LSP.Handlers (ServerM config)
|
||||
-> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
|
||||
-> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)
|
||||
-> MVar ()
|
||||
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
|
||||
LSP.Handlers (ServerM config),
|
||||
@ -189,7 +191,7 @@ handleInit
|
||||
:: Recorder (WithPriority Log)
|
||||
-> FilePath -- ^ root directory, see Note [Root Directory]
|
||||
-> (FilePath -> IO FilePath)
|
||||
-> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
|
||||
-> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)
|
||||
-> MVar ()
|
||||
-> IO ()
|
||||
-> (SomeLspId -> IO ())
|
||||
@ -236,8 +238,8 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c
|
||||
exceptionInHandler e
|
||||
k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing
|
||||
_ <- flip forkFinally handleServerException $ do
|
||||
untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do
|
||||
putMVar dbMVar (WithHieDbShield withHieDb',hieChan')
|
||||
untilMVar lifetime $ runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do
|
||||
putMVar dbMVar (WithHieDbShield withHieDb',threadQueue')
|
||||
forever $ do
|
||||
msg <- readChan clientMsgChan
|
||||
-- We dispatch notifications synchronously and requests asynchronously
|
||||
@ -247,12 +249,22 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c
|
||||
ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
|
||||
logWith recorder Info LogReactorThreadStopped
|
||||
|
||||
(WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar
|
||||
ide <- getIdeState env root withHieDb hieChan
|
||||
(WithHieDbShield withHieDb, threadQueue) <- takeMVar dbMVar
|
||||
ide <- getIdeState env root withHieDb threadQueue
|
||||
registerIdeConfiguration (shakeExtras ide) initConfig
|
||||
pure $ Right (env,ide)
|
||||
|
||||
|
||||
-- | runWithWorkerThreads
|
||||
-- create several threads to run the session, db and session loader
|
||||
-- see Note [Serializing runs in separate thread]
|
||||
runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
|
||||
runWithWorkerThreads recorder dbLoc f = evalContT $ do
|
||||
sessionRestartTQueue <- withWorkerQueue id
|
||||
sessionLoaderTQueue <- withWorkerQueue id
|
||||
(WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc
|
||||
liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)
|
||||
|
||||
-- | Runs the action until it ends or until the given MVar is put.
|
||||
-- Rethrows any exceptions.
|
||||
untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
|
||||
|
@ -24,7 +24,6 @@ import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Default (Default (def))
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Hashable (hashed)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List.Extra (intercalate,
|
||||
@ -54,12 +53,13 @@ import Development.IDE.Core.Service (initialise,
|
||||
runAction)
|
||||
import qualified Development.IDE.Core.Service as Service
|
||||
import Development.IDE.Core.Shake (IdeState (shakeExtras),
|
||||
IndexQueue,
|
||||
ThreadQueue (tLoaderQueue),
|
||||
shakeSessionInit,
|
||||
uses)
|
||||
import qualified Development.IDE.Core.Shake as Shake
|
||||
import Development.IDE.Graph (action)
|
||||
import Development.IDE.LSP.LanguageServer (runLanguageServer,
|
||||
runWithWorkerThreads,
|
||||
setupLSP)
|
||||
import qualified Development.IDE.LSP.LanguageServer as LanguageServer
|
||||
import Development.IDE.Main.HeapStats (withHeapStats)
|
||||
@ -74,7 +74,6 @@ import Development.IDE.Session (SessionLoadingOptions
|
||||
getHieDbLoc,
|
||||
loadSessionWithOptions,
|
||||
retryOnSqliteBusy,
|
||||
runWithDb,
|
||||
setInitialDynFlags)
|
||||
import qualified Development.IDE.Session as Session
|
||||
import Development.IDE.Types.Location (NormalizedUri,
|
||||
@ -326,8 +325,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
|
||||
logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)
|
||||
|
||||
ideStateVar <- newEmptyMVar
|
||||
let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState
|
||||
getIdeState env rootPath withHieDb hieChan = do
|
||||
let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState
|
||||
getIdeState env rootPath withHieDb threadQueue = do
|
||||
t <- ioT
|
||||
logWith recorder Info $ LogLspStartDuration t
|
||||
-- We want to set the global DynFlags right now, so that we can use
|
||||
@ -337,7 +336,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
|
||||
-- TODO: should probably catch/log/rethrow at top level instead
|
||||
`catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing)
|
||||
|
||||
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath
|
||||
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue)
|
||||
config <- LSP.runLspT env LSP.getConfig
|
||||
let def_options = argsIdeOptions config sessionLoader
|
||||
|
||||
@ -361,7 +360,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
|
||||
debouncer
|
||||
ideOptions
|
||||
withHieDb
|
||||
hieChan
|
||||
threadQueue
|
||||
monitoring
|
||||
rootPath
|
||||
putMVar ideStateVar ide
|
||||
@ -387,7 +386,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
|
||||
Check argFiles -> do
|
||||
let dir = argsProjectRoot
|
||||
dbLoc <- getHieDbLoc dir
|
||||
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
|
||||
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do
|
||||
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
|
||||
hSetEncoding stdout utf8
|
||||
hSetEncoding stderr utf8
|
||||
@ -408,14 +407,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
|
||||
putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
|
||||
when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")"
|
||||
putStrLn "\nStep 3/4: Initializing the IDE"
|
||||
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
|
||||
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue threadQueue)
|
||||
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
|
||||
ideOptions = def_options
|
||||
{ optCheckParents = pure NeverCheck
|
||||
, optCheckProject = pure False
|
||||
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
|
||||
}
|
||||
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty dir
|
||||
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir
|
||||
shakeSessionInit (cmapWithPrio LogShake recorder) ide
|
||||
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
|
||||
|
||||
@ -445,15 +444,15 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
|
||||
Custom (IdeCommand c) -> do
|
||||
let root = argsProjectRoot
|
||||
dbLoc <- getHieDbLoc root
|
||||
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
|
||||
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."
|
||||
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do
|
||||
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue)
|
||||
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
|
||||
ideOptions = def_options
|
||||
{ optCheckParents = pure NeverCheck
|
||||
, optCheckProject = pure False
|
||||
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
|
||||
}
|
||||
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty root
|
||||
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root
|
||||
shakeSessionInit (cmapWithPrio LogShake recorder) ide
|
||||
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
|
||||
c ide
|
||||
|
@ -12,7 +12,7 @@ module Development.IDE.Types.Shake
|
||||
ShakeValue(..),
|
||||
currentValue,
|
||||
isBadDependency,
|
||||
toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb)
|
||||
toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb,WithHieDbShield(..))
|
||||
where
|
||||
|
||||
import Control.DeepSeq
|
||||
@ -42,6 +42,9 @@ import Unsafe.Coerce (unsafeCoerce)
|
||||
-- functionality
|
||||
type WithHieDb = forall a. (HieDb -> IO a) -> IO a
|
||||
|
||||
-- used to smuggle RankNType WithHieDb through dbMVar
|
||||
newtype WithHieDbShield = WithHieDbShield WithHieDb
|
||||
|
||||
data Value v
|
||||
= Succeeded (Maybe FileVersion) v
|
||||
| Stale (Maybe PositionDelta) (Maybe FileVersion) v
|
||||
|
Loading…
Reference in New Issue
Block a user