mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 16:56:14 +03:00
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>
This commit is contained in:
parent
efcb8e2589
commit
cdc8f78a98
215
exe/Wrapper.hs
215
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)
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user