@@ -38,8 +38,12 @@ import Development.IDE.Core.Tracing
3838import Development.IDE.LSP.HoverDefinition
3939import Development.IDE.Types.Logger
4040
41+ import Control.Monad.IO.Unlift (MonadUnliftIO )
4142import System.IO.Unsafe (unsafeInterleaveIO )
4243
44+ issueTrackerUrl :: T. Text
45+ issueTrackerUrl = " https://github.com/haskell/haskell-language-server/issues"
46+
4347runLanguageServer
4448 :: forall config . (Show config )
4549 => LSP. Options
@@ -54,11 +58,16 @@ runLanguageServer
5458runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do
5559
5660 -- This MVar becomes full when the server thread exits or we receive exit message from client.
57- -- LSP loop will be canceled when it's full.
61+ -- LSP server will be canceled when it's full.
5862 clientMsgVar <- newEmptyMVar
5963 -- Forcefully exit
6064 let exit = void $ tryPutMVar clientMsgVar ()
6165
66+ -- An MVar to control the lifetime of the reactor loop.
67+ -- The loop will be stopped and resources freed when it's full
68+ reactorLifetime <- newEmptyMVar
69+ let stopReactorLoop = void $ tryPutMVar reactorLifetime ()
70+
6271 -- The set of requests ids that we have received but not finished processing
6372 pendingRequests <- newTVarIO Set. empty
6473 -- The set of requests that have been cancelled and are also in pendingRequests
@@ -93,7 +102,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
93102 [ ideHandlers
94103 , cancelHandler cancelRequest
95104 , exitHandler exit
96- , shutdownHandler
105+ , shutdownHandler stopReactorLoop
97106 ]
98107 -- Cancel requests are special since they need to be handled
99108 -- out of order to be useful. Existing handlers are run afterwards.
@@ -102,25 +111,23 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
102111 let serverDefinition = LSP. ServerDefinition
103112 { LSP. onConfigurationChange = onConfigurationChange
104113 , LSP. defaultConfig = defaultConfig
105- , LSP. doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan
114+ , LSP. doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan
106115 , LSP. staticHandlers = asyncHandlers
107116 , LSP. interpretHandler = \ (env, st) -> LSP. IsoLSP. runLspT env . flip runReaderT (clientMsgChan,st)) liftIO
108117 , LSP. options = modifyOptions options
109118 }
110119
111- void $ waitAnyCancel =<< traverse async
112- [ void $ LSP. runServerWithHandles
120+ void $ untilMVar clientMsgVar $
121+ void $ LSP. runServerWithHandles
113122 inH
114123 outH
115124 serverDefinition
116- , void $ readMVar clientMsgVar
117- ]
118125
119126 where
120127 handleInit
121- :: IO () -> (SomeLspId -> IO () ) -> (SomeLspId -> IO () ) -> Chan ReactorMessage
128+ :: MVar () -> IO () -> (SomeLspId -> IO () ) -> (SomeLspId -> IO () ) -> Chan ReactorMessage
122129 -> LSP. LanguageContextEnvconfig -> RequestMessage Initialize -> IO Either err (LSP. LanguageContextEnvconfig , IdeState ))
123- handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler " Initialize" show m) $ \ sp -> do
130+ handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler " Initialize" show m) $ \ sp -> do
124131 traceWithSpan sp params
125132 let root = LSP. resRootPath env
126133 dir <- maybe getCurrentDirectory return root
@@ -138,58 +145,73 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
138145 registerIdeConfiguration (shakeExtras ide) initConfig
139146
140147 let handleServerException (Left = do
141- logError (ideLogger ide) $
148+ logError logger $
142149 T. pack $ " Fatal error in server thread: " <> show e
150+ sendErrorMessage e
143151 exitClientMsg
144- handleServerException _ = pure ()
152+ handleServerException (Right = pure ()
153+
154+ sendErrorMessage (e :: SomeException ) = do
155+ LSP. runLspT env $ LSP. sendNotification SWindowShowMessage $
156+ ShowMessageParams MtError $ T. unlines
157+ [ " Unhandled exception, please [report](" <> issueTrackerUrl <> " ): "
158+ , T. pack(show e)
159+ ]
160+
161+ exceptionInHandler e = do
162+ logError logger $ T. pack $
163+ " Unexpected exception, please report!\n " ++
164+ " Exception: " ++ show e
165+ sendErrorMessage e
166+
145167 logger = ideLogger ide
146- _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \ hiedb hieChan -> do
147- putMVar dbMVar (hiedb,hieChan)
148- forever $ do
149- msg <- readChan clientMsgChan
150- -- We dispatch notifications synchronously and requests asynchronously
151- -- This is to ensure that all file edits and config changes are applied before a request is handled
152- case msg of
153- ReactorNotification act -> do
154- catch act $ \ (e :: SomeException ) ->
155- logError (ideLogger ide) $ T. pack $
156- " Unexpected exception on notification, please report!\n " ++
157- " Exception: " ++ show e
158- ReactorRequest _id act k -> void $ async $
159- checkCancelled ide clearReqId waitForCancel _id act k
168+
169+ checkCancelled _id act k =
170+ flip finally (clearReqId _id) $
171+ catch (do
172+ -- We could optimize this by first checking if the id
173+ -- is in the cancelled set. However, this is unlikely to be a
174+ -- bottleneck and the additional check might hide
175+ -- issues with async exceptions that need to be fixed.
176+ cancelOrRes <- race (waitForCancel _id) act
177+ case cancelOrRes of
178+ Left () -> do
179+ logDebug (ideLogger ide) $ T. pack $ " Cancelled request " <> show _id
180+ k $ ResponseError RequestCancelled " " Nothing
181+ Right -> pure res
182+ ) $ \ (e :: SomeException ) -> do
183+ exceptionInHandler e
184+ k $ ResponseError InternalError (T. pack $ show e) Nothing
185+ _ <- flip forkFinally handleServerException $ do
186+ untilMVar lifetime $ runWithDb logger dbLoc $ \ hiedb hieChan -> do
187+ putMVar dbMVar (hiedb,hieChan)
188+ forever $ do
189+ msg <- readChan clientMsgChan
190+ -- We dispatch notifications synchronously and requests asynchronously
191+ -- This is to ensure that all file edits and config changes are applied before a request is handled
192+ case msg of
193+ ReactorNotification act -> handle exceptionInHandler act
194+ ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
195+ logInfo logger " Reactor thread stopped"
160196 pure $ Right
161197
162- checkCancelled
163- :: IdeState -> (SomeLspId -> IO () ) -> (SomeLspId -> IO () ) -> SomeLspId
164- -> IO () -> (ResponseError -> IO () ) -> IO ()
165- checkCancelled ide clearReqId waitForCancel _id act k =
166- flip finally (clearReqId _id) $
167- catch (do
168- -- We could optimize this by first checking if the id
169- -- is in the cancelled set. However, this is unlikely to be a
170- -- bottleneck and the additional check might hide
171- -- issues with async exceptions that need to be fixed.
172- cancelOrRes <- race (waitForCancel _id) act
173- case cancelOrRes of
174- Left () -> do
175- logDebug (ideLogger ide) $ T. pack $ " Cancelled request " <> show _id
176- k $ ResponseError RequestCancelled " " Nothing
177- Right -> pure res
178- ) $ \ (e :: SomeException ) -> do
179- logError (ideLogger ide) $ T. pack $
180- " Unexpected exception on request, please report!\n " ++
181- " Exception: " ++ show e
182- k $ ResponseError InternalError (T. pack $ show e) Nothing
183198
199+ -- | Runs the action until it ends or until the given MVar is put.
200+ -- Rethrows any exceptions.
201+ untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
202+ untilMVar mvar io = void $
203+ waitAnyCancel =<< traverse async [ io , readMVar mvar ]
184204
185205cancelHandler :: (SomeLspId -> IO () ) -> LSP. HandlersServerM c )
186206cancelHandler cancelRequest = LSP. notificationHandler SCancelRequest $ \ NotificationMessage {_params= CancelParams {_id}} ->
187207 liftIO $ cancelRequest (SomeLspId _id)
188208
189- shutdownHandler :: LSP. HandlersServerM c )
190- shutdownHandler = LSP. requestHandler SShutdown $ \ _ resp -> do
209+ shutdownHandler :: IO () -> LSP. HandlersServerM c )
210+ shutdownHandler stopReactor = LSP. requestHandler SShutdown $ \ _ resp -> do
191211 (_, ide) <- ask
192- liftIO $ logDebug (ideLogger ide) " Received exit message"
212+ liftIO $ logDebug (ideLogger ide) " Received shutdown message"
213+ -- stop the reactor to free up the hiedb connection
214+ liftIO stopReactor
193215 -- flush out the Shake session to record a Shake profile if applicable
194216 liftIO $ shakeShut ide
195217 resp $ Right Empty
0 commit comments