diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index b721a4f3f5..23cc153215 100644 --- a/exe/Wrapper.hs +++ b/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) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 97eb1675af..798ea40a68 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/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. diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index 19e438e0da..b47bc46f90 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index aa62c60ecf..585a2badb7 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/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 - - 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) - - 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 - - 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 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 + + -- 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 + + -- 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 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 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index cf63af660d..970bb6b8fb 100644 --- a/haskell-language-server.cabal +++ b/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