Turn HLS-wrapper into an LSP Server (#2960)

* Make wrapper a LSP on failure

* Fix incorrect imports

* revert import block for smaller diff

* add missing imports

* Fix: callProcess on win32 machines not called

* import container only on win32

* add missing liftIO

Co-authored-by: Pepe Iborra <pepeiborra@gmail.com>

exe/Wrapper.hs

@@ -1,6 +1,12 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE ExplicitNamespaces         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 -- | This module is based on the hie-wrapper.sh script in
 -- https://github.com/alanz/vscode-hie-server
 module Main where
@@ -28,6 +34,28 @@ import qualified Data.Map.Strict as Map
 #else
 import           System.Process
 #endif
+import qualified Data.Text.IO as T
+import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
+import qualified Data.Text as T
+import           Language.LSP.Server (LspM)
+import           Control.Monad.IO.Class (MonadIO (liftIO))
+import           Control.Monad.IO.Unlift (MonadUnliftIO)
+import qualified Language.LSP.Server as LSP
+import qualified Development.IDE.Main as Main
+import           Ide.Plugin.Config (Config)
+import           Language.LSP.Types (RequestMessage, ResponseError, MessageActionItem (MessageActionItem), Method(Initialize), MessageType (MtError), SMethod (SWindowShowMessageRequest, SExit), ShowMessageRequestParams (ShowMessageRequestParams))
+import           Development.IDE.Types.Logger ( makeDefaultStderrRecorder,
+                                                cmapWithPrio,
+                                                Pretty(pretty),
+                                                Logger(Logger),
+                                                Priority(Error, Debug, Info, Warning),
+                                                Recorder(logger_),
+                                                WithPriority(WithPriority) )
+import           Data.Maybe
+import           GHC.Stack.Types (emptyCallStack)
+import           Control.Concurrent (tryPutMVar)
+import           Development.IDE.LSP.LanguageServer (runLanguageServer)
+import           HIE.Bios.Internal.Log
 
 -- ---------------------------------------------------------------------
 
@@ -57,9 +85,15 @@ main = do
           cradle <- findProjectCradle' False
           (CradleSuccess libdir) <- HieBios.getRuntimeGhcLibDir cradle
           putStr libdir
-      _ -> launchHaskellLanguageServer args
+      _ -> launchHaskellLanguageServer args >>= \case
+            Right () -> pure ()
+            Left err -> do
+              T.hPutStrLn stderr (prettyError err NoShorten)
+              case args of
+                Ghcide _ -> launchErrorLSP (prettyError err Shorten)
+                _        -> pure ()
 
-launchHaskellLanguageServer :: Arguments -> IO ()
+launchHaskellLanguageServer :: Arguments -> IO (Either WrapperSetupError ())
 launchHaskellLanguageServer parsedArgs = do
   case parsedArgs of
     Ghcide GhcideArguments{..} -> whenJust argsCwd setCurrentDirectory
@@ -75,7 +109,10 @@ launchHaskellLanguageServer parsedArgs = do
 
   case parsedArgs of
     Ghcide GhcideArguments{..} ->
-      when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
+      when argsProjectGhcVersion $ do
+        runExceptT (getRuntimeGhcVersion' cradle) >>= \case
+          Right ghcVersion -> putStrLn ghcVersion >> exitSuccess
+          Left err -> T.putStrLn (prettyError err NoShorten) >> exitFailure
     _ -> pure ()
 
   progName <- getProgName
@@ -94,64 +131,74 @@ launchHaskellLanguageServer parsedArgs = do
   hPutStrLn stderr ""
   -- Get the ghc version -- this might fail!
   hPutStrLn stderr "Consulting the cradle to get project GHC version..."
-  ghcVersion <- getRuntimeGhcVersion' cradle
-  hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion
 
-  let
-    hlsBin = "haskell-language-server-" ++ ghcVersion
-    candidates' = [hlsBin, "haskell-language-server"]
-    candidates = map (++ exeExtension) candidates'
+  runExceptT $ do
+      ghcVersion <- getRuntimeGhcVersion' cradle
+      liftIO $ hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion
 
-  hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates
+      let
+        hlsBin = "haskell-language-server-" ++ ghcVersion
+        candidates' = [hlsBin, "haskell-language-server"]
+        candidates = map (++ exeExtension) candidates'
 
-  mexes <- traverse findExecutable candidates
+      liftIO $ hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates
+
+      mexes <- liftIO $ traverse findExecutable candidates
+
+      case asum mexes of
+        Nothing -> throwE (NoLanguageServer ghcVersion candidates)
+        Just e -> do
+          liftIO $ hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e
 
-  case asum mexes of
-    Nothing -> die $ "Cannot find any haskell-language-server exe, looked for: " ++ intercalate ", " candidates
-    Just e -> do
-      hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e
 #ifdef mingw32_HOST_OS
-      callProcess e args
+          liftIO $ callProcess e args
 #else
-      let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle
-      -- we need to be compatible with NoImplicitPrelude
-      ghcBinary <- (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"])
-        >>= cradleResult "Failed to get project GHC executable path"
-      libdir <- HieBios.getRuntimeGhcLibDir cradle
-        >>= cradleResult "Failed to get project GHC libdir path"
-      env <- Map.fromList <$> getEnvironment
-      let newEnv = Map.insert "GHC_BIN" ghcBinary $ Map.insert "GHC_LIBDIR" libdir env
-      executeFile e True args (Just (Map.toList newEnv))
+
+          let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle
+
+          let cradleName = actionName (cradleOptsProg cradle)
+          -- we need to be compatible with NoImplicitPrelude
+          ghcBinary <- liftIO (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"])
+                         >>= cradleResult cradleName
+
+          libdir <- liftIO (HieBios.getRuntimeGhcLibDir cradle)
+                      >>= cradleResult cradleName
+
+          env <- Map.fromList <$> liftIO getEnvironment
+          let newEnv = Map.insert "GHC_BIN" ghcBinary $ Map.insert "GHC_LIBDIR" libdir env
+          liftIO $ executeFile e True args (Just (Map.toList newEnv))
 #endif
 
 
-cradleResult :: String -> CradleLoadResult a -> IO a
-cradleResult _ (CradleSuccess a) = pure a
-cradleResult str (CradleFail e) = die $ str ++ ": " ++ show e
-cradleResult str CradleNone = die $ str ++ ": no cradle"
+
+cradleResult :: ActionName Void -> CradleLoadResult a -> ExceptT WrapperSetupError IO a
+cradleResult _ (CradleSuccess ver) = pure ver
+cradleResult cradleName (CradleFail error) = throwE $ FailedToObtainGhcVersion cradleName error
+cradleResult cradleName CradleNone = throwE $ NoneCradleGhcVersion cradleName
 
 -- | Version of 'getRuntimeGhcVersion' that dies if we can't get it, and also
 -- checks to see if the tool is missing if it is one of
-getRuntimeGhcVersion' :: Show a => Cradle a -> IO String
+getRuntimeGhcVersion' :: Cradle Void -> ExceptT WrapperSetupError IO String
 getRuntimeGhcVersion' cradle = do
+  let cradleName = actionName (cradleOptsProg cradle)
 
   -- See if the tool is installed
-  case actionName (cradleOptsProg cradle) of
+  case cradleName of
     Stack   -> checkToolExists "stack"
     Cabal   -> checkToolExists "cabal"
     Default -> checkToolExists "ghc"
     Direct  -> checkToolExists "ghc"
     _       -> pure ()
 
-  HieBios.getRuntimeGhcVersion cradle >>= cradleResult "Failed to get project GHC version"
+  ghcVersionRes <- liftIO $ HieBios.getRuntimeGhcVersion cradle
+  cradleResult cradleName ghcVersionRes
+
   where
     checkToolExists exe = do
-      exists <- findExecutable exe
+      exists <- liftIO $ findExecutable exe
       case exists of
         Just _ -> pure ()
-        Nothing ->
-          die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n"
-           ++ show cradle
+        Nothing -> throwE $ ToolRequirementMissing exe (actionName (cradleOptsProg cradle))
 
 findProjectCradle :: IO (Cradle Void)
 findProjectCradle = findProjectCradle' True
@@ -175,3 +222,93 @@ trim :: String -> String
 trim s = case lines s of
   [] -> s
   ls -> dropWhileEnd isSpace $ last ls
+
+data WrapperSetupError
+    = FailedToObtainGhcVersion (ActionName Void) CradleError
+    | NoneCradleGhcVersion (ActionName Void)
+    | NoLanguageServer String [FilePath]
+    | ToolRequirementMissing String (ActionName Void)
+    deriving (Show)
+
+data Shorten = Shorten | NoShorten
+
+-- | Pretty error message displayable to the future.
+-- Extra argument 'Shorten' can be used to shorten error message.
+-- Reduces usefulness, but allows us to show the error message via LSP
+-- as LSP doesn't allow any newlines and makes it really hard to read
+-- the message otherwise.
+prettyError :: WrapperSetupError -> Shorten ->  T.Text
+prettyError (FailedToObtainGhcVersion name crdlError) shorten =
+  "Failed to find the GHC version of this " <> T.pack (show name) <> " project." <>
+  case shorten of
+    Shorten ->
+      "\n" <> T.pack (fromMaybe "" . listToMaybe $ cradleErrorStderr crdlError)
+    NoShorten ->
+      "\n" <> T.pack (intercalate "\n" (cradleErrorStderr crdlError))
+prettyError (NoneCradleGhcVersion name) _ =
+  "Failed to get the GHC version of this " <> T.pack (show name) <>
+  " project because a none cradle is configured"
+prettyError (NoLanguageServer ghcVersion candidates) _ =
+  "Failed to find a HLS version for GHC " <> T.pack ghcVersion <>
+  "\nExecutable names we failed to find: " <> T.pack (intercalate "," candidates)
+prettyError (ToolRequirementMissing toolExe name) _ =
+  "Failed to find executable \"" <> T.pack toolExe <> "\" in $PATH for this " <> T.pack (show name) <> " project."
+
+newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, LSP.MonadLsp c)
+
+-- | Launches a LSP that displays an error and presents the user with a request
+-- to shut down the LSP.
+launchErrorLSP :: T.Text -> IO ()
+launchErrorLSP errorMsg = do
+  recorder <- makeDefaultStderrRecorder Nothing Info
+
+  let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack (pretty m))
+
+  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) logger
+
+  inH <- Main.argsHandleIn defaultArguments
+
+  outH <- Main.argsHandleOut defaultArguments
+
+  let onConfigurationChange cfg _ = Right cfg
+
+  let setup clientMsgVar = do
+        -- Forcefully exit
+        let exit = void $ tryPutMVar clientMsgVar ()
+
+        let doInitialize :: LSP.LanguageContextEnv Config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv Config, ()))
+            doInitialize env _ = do
+
+              let restartTitle = "Try to restart"
+              void $ LSP.runLspT env $ LSP.sendRequest SWindowShowMessageRequest (ShowMessageRequestParams MtError errorMsg (Just [MessageActionItem restartTitle])) $ \case
+                    Right (Just (MessageActionItem title))
+                       | title == restartTitle -> liftIO exit
+                    _ -> pure ()
+
+              pure (Right (env, ()))
+
+        let asyncHandlers = mconcat
+              [ exitHandler exit ]
+
+        let interpretHandler (env,  _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO
+        pure (doInitialize, asyncHandlers, interpretHandler)
+
+  runLanguageServer
+    (Main.argsLspOptions defaultArguments)
+    inH
+    outH
+    (Main.argsDefaultHlsConfig defaultArguments)
+    onConfigurationChange
+    setup
+
+exitHandler :: IO () -> LSP.Handlers (ErrorLSPM c)
+exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit
+
+hlsWrapperLogger :: Logger
+hlsWrapperLogger = Logger $ \pri txt ->
+    case pri of
+      Debug   -> debugm   (T.unpack txt)
+      Info    -> logm     (T.unpack txt)
+      Warning -> warningm (T.unpack txt)
+      Error   -> errorm   (T.unpack txt)

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

@@ -5,11 +5,13 @@
 {-# LANGUAGE GADTs                     #-}
 {-# LANGUAGE PolyKinds                 #-}
 {-# LANGUAGE RankNTypes                #-}
+{-# LANGUAGE StarIsType                #-}
 
 -- 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(..)
     ) where
 
@@ -38,9 +40,12 @@ import           Development.IDE.Core.Tracing
 import           Development.IDE.Types.Logger
 
 import           Control.Monad.IO.Unlift               (MonadUnliftIO)
+import           Data.Kind                             (Type)
 import qualified Development.IDE.Session               as Session
 import qualified Development.IDE.Types.Logger          as Logger
 import           Development.IDE.Types.Shake           (WithHieDb)
+import           Language.LSP.Server                   (LanguageContextEnv,
+                                                        type (<~>))
 import           System.IO.Unsafe                      (unsafeInterleaveIO)
 
 data Log
@@ -74,71 +79,30 @@ instance Pretty Log where
 newtype WithHieDbShield = WithHieDbShield WithHieDb
 
 runLanguageServer
-    :: forall config. (Show config)
-    => Recorder (WithPriority Log)
-    -> LSP.Options
+    :: forall config a m. (Show config)
+    => LSP.Options
     -> Handle -- input
     -> Handle -- output
-    -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
     -> config
     -> (config -> Value -> Either T.Text config)
-    -> LSP.Handlers (ServerM config)
-    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
+    -> (MVar ()
+        -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)),
+               LSP.Handlers (m config),
+               (LanguageContextEnv config, a) -> m config <~> IO))
     -> IO ()
-runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do
-
+runLanguageServer options inH outH defaultConfig onConfigurationChange 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
-    -- Forcefully exit
-    let exit = void $ tryPutMVar clientMsgVar ()
-
-    -- An MVar to control the lifetime of the reactor loop.
-    -- The loop will be stopped and resources freed when it's full
-    reactorLifetime <- newEmptyMVar
-    let stopReactorLoop = void $ tryPutMVar reactorLifetime ()
-
-    -- The set of requests ids that we have received but not finished processing
-    pendingRequests <- newTVarIO Set.empty
-    -- The set of requests that have been cancelled and are also in pendingRequests
-    cancelledRequests <- newTVarIO Set.empty
-
-    let cancelRequest reqId = atomically $ do
-            queued <- readTVar pendingRequests
-            -- We want to avoid that the list of cancelled requests
-            -- keeps growing if we receive cancellations for requests
-            -- that do not exist or have already been processed.
-            when (reqId `elem` queued) $
-                modifyTVar cancelledRequests (Set.insert reqId)
-    let clearReqId reqId = atomically $ do
-            modifyTVar pendingRequests (Set.delete reqId)
-            modifyTVar cancelledRequests (Set.delete reqId)
-        -- We implement request cancellation by racing waitForCancel against
-        -- the actual request handler.
-    let waitForCancel reqId = atomically $ do
-            cancelled <- readTVar cancelledRequests
-            unless (reqId `Set.member` cancelled) retry
-
-    -- Send everything over a channel, since you need to wait until after initialise before
-    -- LspFuncs is available
-    clientMsgChan :: Chan ReactorMessage <- newChan
-
-    let asyncHandlers = mconcat
-          [ userHandlers
-          , cancelHandler cancelRequest
-          , exitHandler exit
-          , shutdownHandler stopReactorLoop
-          ]
-          -- Cancel requests are special since they need to be handled
-          -- out of order to be useful. Existing handlers are run afterwards.
 
+    (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar
 
     let serverDefinition = LSP.ServerDefinition
             { LSP.onConfigurationChange = onConfigurationChange
             , LSP.defaultConfig = defaultConfig
-            , LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan
-            , LSP.staticHandlers = asyncHandlers
-            , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO
+            , LSP.doInitialize = doInitialize
+            , LSP.staticHandlers = staticHandlers
+            , LSP.interpretHandler = interpretHandler
             , LSP.options = modifyOptions options
             }
 
@@ -148,67 +112,134 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur
             outH
             serverDefinition
 
+setupLSP ::
+     forall config err.
+     Recorder (WithPriority Log)
+  -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
+  -> LSP.Handlers (ServerM config)
+  -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
+  -> MVar ()
+  -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
+         LSP.Handlers (ServerM config),
+         (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
+setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
+  -- Send everything over a channel, since you need to wait until after initialise before
+  -- LspFuncs is available
+  clientMsgChan :: Chan ReactorMessage <- newChan
+
+  -- An MVar to control the lifetime of the reactor loop.
+  -- The loop will be stopped and resources freed when it's full
+  reactorLifetime <- newEmptyMVar
+  let stopReactorLoop = void $ tryPutMVar reactorLifetime ()
+
+  -- Forcefully exit
+  let exit = void $ tryPutMVar clientMsgVar ()
+
+  -- The set of requests ids that we have received but not finished processing
+  pendingRequests <- newTVarIO Set.empty
+  -- The set of requests that have been cancelled and are also in pendingRequests
+  cancelledRequests <- newTVarIO Set.empty
+
+  let cancelRequest reqId = atomically $ do
+          queued <- readTVar pendingRequests
+          -- We want to avoid that the list of cancelled requests
+          -- keeps growing if we receive cancellations for requests
+          -- that do not exist or have already been processed.
+          when (reqId `elem` queued) $
+              modifyTVar cancelledRequests (Set.insert reqId)
+  let clearReqId reqId = atomically $ do
+          modifyTVar pendingRequests (Set.delete reqId)
+          modifyTVar cancelledRequests (Set.delete reqId)
+      -- We implement request cancellation by racing waitForCancel against
+      -- the actual request handler.
+  let waitForCancel reqId = atomically $ do
+          cancelled <- readTVar cancelledRequests
+          unless (reqId `Set.member` cancelled) retry
+
+  let asyncHandlers = mconcat
+        [ userHandlers
+        , cancelHandler cancelRequest
+        , exitHandler exit
+        , shutdownHandler stopReactorLoop
+        ]
+        -- Cancel requests are special since they need to be handled
+        -- out of order to be useful. Existing handlers are run afterwards.
+
+  let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan
+
+  let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO
+
+  pure (doInitialize, asyncHandlers, interpretHandler)
+
+
+handleInit
+    :: Recorder (WithPriority Log)
+    -> (FilePath -> IO FilePath)
+    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
+    -> MVar ()
+    -> IO ()
+    -> (SomeLspId -> IO ())
+    -> (SomeLspId -> IO ())
+    -> Chan ReactorMessage
+    -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
+handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
+    traceWithSpan sp params
+    let root = LSP.resRootPath env
+    dir <- maybe getCurrentDirectory return root
+    dbLoc <- getHieDbLoc dir
+
+    -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference
+    -- to 'getIdeState', so we use this dirty trick
+    dbMVar <- newEmptyMVar
+    ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar
+
+    ide <- getIdeState env root withHieDb hieChan
+
+    let initConfig = parseConfiguration params
+
+    log Info $ LogRegisteringIdeConfig initConfig
+    registerIdeConfiguration (shakeExtras ide) initConfig
+
+    let handleServerException (Left e) = do
+            log Error $ LogReactorThreadException e
+            exitClientMsg
+        handleServerException (Right _) = pure ()
+
+        exceptionInHandler e = do
+            log Error $ LogReactorMessageActionException e
+
+        checkCancelled _id act k =
+            flip finally (clearReqId _id) $
+                catch (do
+                    -- We could optimize this by first checking if the id
+                    -- is in the cancelled set. However, this is unlikely to be a
+                    -- bottleneck and the additional check might hide
+                    -- issues with async exceptions that need to be fixed.
+                    cancelOrRes <- race (waitForCancel _id) act
+                    case cancelOrRes of
+                        Left () -> do
+                            log Debug $ LogCancelledRequest _id
+                            k $ ResponseError RequestCancelled "" Nothing
+                        Right res -> pure res
+                ) $ \(e :: SomeException) -> do
+                    exceptionInHandler e
+                    k $ ResponseError 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)
+            forever $ do
+                msg <- readChan clientMsgChan
+                -- We dispatch notifications synchronously and requests asynchronously
+                -- This is to ensure that all file edits and config changes are applied before a request is handled
+                case msg of
+                    ReactorNotification act -> handle exceptionInHandler act
+                    ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
+        log Info LogReactorThreadStopped
+    pure $ Right (env,ide)
+
     where
-        log :: Logger.Priority -> Log -> IO ()
-        log = logWith recorder
-
-        handleInit
-          :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
-          -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
-        handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
-            traceWithSpan sp params
-            let root = LSP.resRootPath env
-            dir <- maybe getCurrentDirectory return root
-            dbLoc <- getHieDbLoc dir
-
-            -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference
-            -- to 'getIdeState', so we use this dirty trick
-            dbMVar <- newEmptyMVar
-            ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar
-
-            ide <- getIdeState env root withHieDb hieChan
-
-            let initConfig = parseConfiguration params
-
-            log Info $ LogRegisteringIdeConfig initConfig
-            registerIdeConfiguration (shakeExtras ide) initConfig
-
-            let handleServerException (Left e) = do
-                    log Error $ LogReactorThreadException e
-                    exitClientMsg
-                handleServerException (Right _) = pure ()
-
-                exceptionInHandler e = do
-                    log Error $ LogReactorMessageActionException e
-
-                checkCancelled _id act k =
-                    flip finally (clearReqId _id) $
-                        catch (do
-                            -- We could optimize this by first checking if the id
-                            -- is in the cancelled set. However, this is unlikely to be a
-                            -- bottleneck and the additional check might hide
-                            -- issues with async exceptions that need to be fixed.
-                            cancelOrRes <- race (waitForCancel _id) act
-                            case cancelOrRes of
-                                Left () -> do
-                                    log Debug $ LogCancelledRequest _id
-                                    k $ ResponseError RequestCancelled "" Nothing
-                                Right res -> pure res
-                        ) $ \(e :: SomeException) -> do
-                            exceptionInHandler e
-                            k $ ResponseError 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)
-                    forever $ do
-                        msg <- readChan clientMsgChan
-                        -- We dispatch notifications synchronously and requests asynchronously
-                        -- This is to ensure that all file edits and config changes are applied before a request is handled
-                        case msg of
-                            ReactorNotification act -> handle exceptionInHandler act
-                            ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
-                log Info LogReactorThreadStopped
-            pure $ Right (env,ide)
+      log :: Logger.Priority -> Log -> IO ()
+      log = logWith recorder
 
 
 -- | Runs the action until it ends or until the given MVar is put.

ghcide/src/Development/IDE/LSP/Server.hs

@@ -10,11 +10,12 @@
 module Development.IDE.LSP.Server
   ( ReactorMessage(..)
   , ReactorChan
-  , ServerM
+  , ServerM(..)
   , requestHandler
   , notificationHandler
   ) where
 
+import           Control.Monad.IO.Unlift      (MonadUnliftIO)
 import           Control.Monad.Reader
 import           Development.IDE.Core.Shake
 import           Development.IDE.Core.Tracing
@@ -30,7 +31,8 @@ data ReactorMessage
   | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ())
 
 type ReactorChan = Chan ReactorMessage
-type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c)
+newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a }
+  deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c)
 
 requestHandler
   :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) =>
@@ -40,7 +42,7 @@ requestHandler
 requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do
   st@(chan,ide) <- ask
   env <- LSP.getLspEnv
-  let resp' = flip runReaderT st . resp
+  let resp' = flip (runReaderT . unServerM) st . resp
       trace x = otTracedHandler "Request" (show _method) $ \sp -> do
         traceWithSpan sp _params
         x

ghcide/src/Development/IDE/Main.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE PackageImports #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE RankNTypes     #-}
 module Development.IDE.Main
 (Arguments(..)
 ,defaultArguments
@@ -57,13 +58,15 @@ import           Development.IDE.Core.Service             (initialise,
                                                            runAction)
 import qualified Development.IDE.Core.Service             as Service
 import           Development.IDE.Core.Shake               (IdeState (shakeExtras),
+                                                           IndexQueue,
                                                            ShakeExtras (state),
                                                            shakeSessionInit,
                                                            uses)
 import qualified Development.IDE.Core.Shake               as Shake
 import           Development.IDE.Core.Tracing             (measureMemory)
 import           Development.IDE.Graph                    (action)
-import           Development.IDE.LSP.LanguageServer       (runLanguageServer)
+import           Development.IDE.LSP.LanguageServer       (runLanguageServer,
+                                                           setupLSP)
 import qualified Development.IDE.LSP.LanguageServer       as LanguageServer
 import           Development.IDE.Main.HeapStats           (withHeapStats)
 import qualified Development.IDE.Main.HeapStats           as HeapStats
@@ -98,7 +101,8 @@ import           Development.IDE.Types.Options            (IdeGhcSession,
                                                            defaultIdeOptions,
                                                            optModifyDynFlags,
                                                            optTesting)
-import           Development.IDE.Types.Shake              (fromKeyType)
+import           Development.IDE.Types.Shake              (WithHieDb,
+                                                           fromKeyType)
 import           GHC.Conc                                 (getNumProcessors)
 import           GHC.IO.Encoding                          (setLocaleEncoding)
 import           GHC.IO.Handle                            (hDuplicate)
@@ -300,7 +304,6 @@ testing recorder logger =
       , argsIdeOptions = ideOptions
       }
 
-
 defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
 defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
  where
@@ -335,49 +338,54 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             t <- offsetTime
             log Info LogLspStart
 
-            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env rootPath withHieDb hieChan -> do
-                traverse_ IO.setCurrentDirectory rootPath
-                t <- t
-                log Info $ LogLspStartDuration t
+            let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
+                getIdeState env rootPath withHieDb hieChan = do
+                  traverse_ IO.setCurrentDirectory rootPath
+                  t <- t
+                  log Info $ LogLspStartDuration t
 
-                dir <- maybe IO.getCurrentDirectory return rootPath
+                  dir <- maybe IO.getCurrentDirectory return rootPath
 
-                -- We want to set the global DynFlags right now, so that we can use
-                -- `unsafeGlobalDynFlags` even before the project is configured
-                _mlibdir <-
-                    setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions
-                        -- TODO: should probably catch/log/rethrow at top level instead
-                        `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing)
+                  -- We want to set the global DynFlags right now, so that we can use
+                  -- `unsafeGlobalDynFlags` even before the project is configured
+                  _mlibdir <-
+                      setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions
+                          -- TODO: should probably catch/log/rethrow at top level instead
+                          `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing)
 
-                sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
-                config <- LSP.runLspT env LSP.getConfig
-                let def_options = argsIdeOptions config sessionLoader
+                  sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
+                  config <- LSP.runLspT env LSP.getConfig
+                  let def_options = argsIdeOptions config sessionLoader
 
-                -- disable runSubset if the client doesn't support watched files
-                runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported
-                log Debug $ LogShouldRunSubset runSubset
+                  -- disable runSubset if the client doesn't support watched files
+                  runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported
+                  log Debug $ LogShouldRunSubset runSubset
 
-                let options = def_options
-                            { optReportProgress = clientSupportsProgress caps
-                            , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
-                            , optRunSubset = runSubset
-                            }
-                    caps = LSP.resClientCapabilities env
-                -- FIXME: Remove this after GHC 9.2 gets fully supported
-                when (ghcVersion == GHC92) $
-                    log Warning LogOnlyPartialGhc92Support
-                monitoring <- argsMonitoring
-                initialise
-                    (cmapWithPrio LogService recorder)
-                    argsDefaultHlsConfig
-                    rules
-                    (Just env)
-                    logger
-                    debouncer
-                    options
-                    withHieDb
-                    hieChan
-                    monitoring
+                  let options = def_options
+                              { optReportProgress = clientSupportsProgress caps
+                              , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
+                              , optRunSubset = runSubset
+                              }
+                      caps = LSP.resClientCapabilities env
+                  -- FIXME: Remove this after GHC 9.2 gets fully supported
+                  when (ghcVersion == GHC92) $
+                      log Warning LogOnlyPartialGhc92Support
+                  monitoring <- argsMonitoring
+                  initialise
+                      (cmapWithPrio LogService recorder)
+                      argsDefaultHlsConfig
+                      rules
+                      (Just env)
+                      logger
+                      debouncer
+                      options
+                      withHieDb
+                      hieChan
+                      monitoring
+
+            let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState
+
+            runLanguageServer options inH outH argsDefaultHlsConfig argsOnConfigChange setup
             dumpSTMStats
         Check argFiles -> do
           dir <- maybe IO.getCurrentDirectory return argsProjectRoot

haskell-language-server.cabal

@@ -460,10 +460,17 @@ executable haskell-language-server-wrapper
     , ghcide
     , gitrev
     , haskell-language-server
+    , hslogger
     , hie-bios
+    , hls-plugin-api
+    , lsp
+    , lsp-types
+    , mtl
     , optparse-applicative
     , optparse-simple
     , process
+    , transformers
+    , unliftio-core
   if !os(windows)
       build-depends:
           unix