concurrency bug fixes/ improvements

exe/Wrapper.hs

@@ -1,4 +1,4 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -38,7 +38,8 @@
 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 @@
               [ 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)

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}} ->

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