diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 2c2401ab6a..2fd885ffb3 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -38,7 +38,8 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT, import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T -import Development.IDE.LSP.LanguageServer (runLanguageServer) +import Development.IDE.LSP.LanguageServer (Setup (..), + runLanguageServer) import qualified Development.IDE.Main as Main import Ide.Logger (Doc, Pretty (pretty), Recorder, WithPriority, @@ -300,7 +301,12 @@ launchErrorLSP recorder errorMsg = do [ exitHandler exit ] let interpretHandler (env, _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO - pure (doInitialize, asyncHandlers, interpretHandler) + pure MkSetup + { doInitialize + , staticHandlers = asyncHandlers + , interpretHandler + , onExit = [exit] + } runLanguageServer (cmapWithPrio pretty recorder) (Main.argsLspOptions defaultArguments) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index cf7845ce08..918e024a4f 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -11,6 +11,7 @@ module Development.IDE.LSP.LanguageServer , Log(..) , ThreadQueue , runWithWorkerThreads + , Setup (..) ) where import Control.Concurrent.STM @@ -81,6 +82,17 @@ instance Pretty Log where LogLspServer msg -> pretty msg LogServerShutdownMessage -> "Received shutdown message" +data Setup config m a + = MkSetup + { doInitialize :: LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)) + -- ^ the callback invoked when the language server receives the 'Method_Initialize' request + , staticHandlers :: LSP.Handlers m + -- ^ the statically known handlers of the lsp server + , interpretHandler :: (LanguageContextEnv config, a) -> m <~> IO + -- ^ how to interpret @m@ to 'IO' and how to lift 'IO' into @m@ + , onExit :: [IO ()] + -- ^ a list of 'IO' actions that clean up resources and must be run when the server shuts down + } runLanguageServer :: forall config a m. (Show config) @@ -90,18 +102,16 @@ runLanguageServer -> Handle -- output -> config -> (config -> Value -> Either T.Text config) - -> (config -> m config ()) - -> (MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)), - LSP.Handlers (m config), - (LanguageContextEnv config, a) -> m config <~> IO)) + -> (config -> m ()) + -> (MVar () -> IO (Setup config m a)) -> IO () runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar - (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar + MkSetup + { doInitialize, staticHandlers, interpretHandler, onExit } <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition { LSP.parseConfig = parseConfig @@ -115,28 +125,29 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh , LSP.options = modifyOptions options } - let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog) + let lspCologAction :: forall io. MonadIO io => Colog.LogAction io (Colog.WithSeverity LspServerLog) lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) - void $ untilMVar clientMsgVar $ - void $ LSP.runServerWithHandles + let runServer = + LSP.runServerWithHandles lspCologAction lspCologAction inH outH serverDefinition + untilMVar clientMsgVar $ + runServer `finally` sequence_ onExit + setupLSP :: - forall config err. + forall config. Recorder (WithPriority Log) -> 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 -> ThreadQueue -> IO IdeState) -> MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), - LSP.Handlers (ServerM config), - (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) + -> IO (Setup config (ServerM config) IdeState) setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available @@ -171,7 +182,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry - let asyncHandlers = mconcat + let staticHandlers = mconcat [ userHandlers , cancelHandler cancelRequest , exitHandler exit @@ -184,7 +195,9 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - pure (doInitialize, asyncHandlers, interpretHandler) + let onExit = [stopReactorLoop, exit] + + pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit} handleInit @@ -266,10 +279,12 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. +-- It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should +-- occur as the final action in a 'finally' or 'bracket', because otherwise this thread will finish early (as soon +-- as the thread receives the BlockedIndefinitelyOnMVar exception) -- Rethrows any exceptions. -untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () -untilMVar mvar io = void $ - waitAnyCancel =<< traverse async [ io , readMVar mvar ] +untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () +untilMVar mvar io = race_ (readMVar mvar) io cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 872e957364..ad4a36327a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -12,7 +12,7 @@ module Development.IDE.Main ) where import Control.Concurrent.Extra (withNumCapabilities) -import Control.Concurrent.MVar (newEmptyMVar, +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Monad.Extra (concatMapM, unless, @@ -318,9 +318,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re ioT <- offsetTime logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) - ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState - getIdeState env rootPath withHieDb threadQueue = do + let getIdeState :: MVar IdeState -> LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState + getIdeState ideStateVar env rootPath withHieDb threadQueue = do t <- ioT logWith recorder Info $ LogLspStartDuration t sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue) @@ -353,9 +352,9 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putMVar ideStateVar ide pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup ideStateVar = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) (getIdeState ideStateVar) -- See Note [Client configuration in Rules] - onConfigChange cfg = do + onConfigChange ideStateVar cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint let cfgObj = J.toJSON cfg mide <- liftIO $ tryReadMVar ideStateVar @@ -368,7 +367,9 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re modifyClientSettings ide (const $ Just cfgObj) return [toNoFileKey Rules.GetClientSettings] - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup + do + ideStateVar <- newEmptyMVar + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig (onConfigChange ideStateVar) (setup ideStateVar) dumpSTMStats Check argFiles -> do let dir = argsProjectRoot