From ff783b2dc484821ed95f8815914dd3ef124aad2d Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 14 Jun 2022 21:33:22 +0200 Subject: [PATCH 1/7] Make wrapper a LSP on failure --- exe/Wrapper.hs | 251 ++++++++++--- .../src/Development/IDE/LSP/LanguageServer.hs | 265 +++++++------ ghcide/src/Development/IDE/LSP/Server.hs | 8 +- ghcide/src/Development/IDE/Main.hs | 350 ++++++++++-------- haskell-language-server.cabal | 7 + 5 files changed, 547 insertions(+), 334 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index b721a4f3f5..ff39a7c7d7 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -1,32 +1,75 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- | This module is based on the hie-wrapper.sh script in -- https://github.com/alanz/vscode-hie-server module Main where import Control.Monad.Extra -import Data.Char (isSpace) +import Data.Char (isSpace) import Data.Default import Data.Foldable import Data.List import Data.Void -import qualified Development.IDE.Session as Session -import qualified HIE.Bios.Environment as HieBios +import qualified Development.IDE.Session as Session +import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types import Ide.Arguments -import Ide.Version +import Ide.Version (findProgramVersions, + hlsVersion, + showProgramVersionOfInterest) import System.Directory import System.Environment import System.Exit import System.FilePath -import System.IO import System.Info -#ifndef mingw32_HOST_OS -import System.Posix.Process (executeFile) -import qualified Data.Map.Strict as Map +import System.IO + +import Control.Concurrent (newChan, tryPutMVar) +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Reader +import Control.Monad.Trans.Except (ExceptT, runExceptT, + throwE) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Development.IDE.LSP.LanguageServer (runLanguageServer) +import Development.IDE.LSP.Server (ReactorChan, + ReactorMessage) +import qualified Development.IDE.Main as Main +import Development.IDE.Types.Logger (WithPriority (WithPriority), + cmapWithPrio, + makeDefaultStderrRecorder) +import qualified Development.IDE.Types.Logger as G +import HIE.Bios.Internal.Log (debugm, errorm, logm, + warningm) +import qualified Ide.Arguments as IdeArgs +import Ide.Plugin.Config (Config) +import Language.LSP.Server (LspM, type (<~>)) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified System.Directory as IO +import qualified System.Log as L +import System.Posix.Process (executeFile) +#if MIN_VERSION_prettyprinter(1,7,0) +import Control.Concurrent.Chan (Chan) +import Development.IDE.Types.Logger (Logger (Logger), + Priority (Info)) +import qualified Development.IDE.Types.Logger as Logger +import GHC.Stack (emptyCallStack) +import Prettyprinter (Pretty (pretty)) #else -import System.Process +import Data.Text.Prettyprint.Doc (Pretty (pretty), vsep) #endif -- --------------------------------------------------------------------- @@ -57,9 +100,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 +124,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 +146,71 @@ 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 - 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 -#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)) -#endif + 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 + + + + 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 -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" + 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)) + + + +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 +234,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.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 :: G.Logger +hlsWrapperLogger = G.Logger $ \pri txt -> + case pri of + G.Debug -> debugm (T.unpack txt) + G.Info -> logm (T.unpack txt) + G.Warning -> warningm (T.unpack txt) + G.Error -> errorm (T.unpack txt) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2ca694781d..9b9bd2a770 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 @@ -39,9 +41,12 @@ import Development.IDE.LSP.HoverDefinition 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 @@ -75,76 +80,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 - - let ideHandlers = mconcat - [ setIdeHandlers - , userHandlers - ] - - -- Send everything over a channel, since you need to wait until after initialise before - -- LspFuncs is available - clientMsgChan :: Chan ReactorMessage <- newChan - - let asyncHandlers = mconcat - [ ideHandlers - , 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 } @@ -154,67 +113,139 @@ 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 ideHandlers = mconcat + [ setIdeHandlers + , userHandlers + ] + let asyncHandlers = mconcat + [ ideHandlers + , 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 5acb2139d5..6076ae10f0 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 @@ -11,127 +12,146 @@ module Development.IDE.Main ,testing ,Log(..) ) where -import Control.Concurrent.Extra (withNumCapabilities) -import Control.Concurrent.STM.Stats (atomically, - dumpSTMStats) -import Control.Exception.Safe (SomeException, catchAny, - displayException) -import Control.Monad.Extra (concatMapM, unless, - when) -import qualified Data.Aeson.Encode.Pretty as A -import Data.Default (Default (def)) -import Data.Foldable (traverse_) -import qualified Data.HashMap.Strict as HashMap -import Data.Hashable (hashed) -import Data.List.Extra (intercalate, isPrefixOf, - nub, nubOrd, partition) -import Data.Maybe (catMaybes, isJust) -import qualified Data.Text as T -import Data.Text.Lazy.Encoding (decodeUtf8) -import qualified Data.Text.Lazy.IO as LT -import Data.Typeable (typeOf) -import Development.IDE (Action, GhcVersion (..), - Priority (Debug, Error), Rules, - ghcVersion, - hDuplicateTo') -import Development.IDE.Core.Debouncer (Debouncer, - newAsyncDebouncer) -import Development.IDE.Core.FileStore (isWatchSupported) -import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), - registerIdeConfiguration) -import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), - kick, - setFilesOfInterest) -import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), - GetHieAst (GetHieAst), - GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - TypeCheck (TypeCheck)) -import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), - mainRule) -import qualified Development.IDE.Core.Rules as Rules -import Development.IDE.Core.Service (initialise, runAction) -import qualified Development.IDE.Core.Service as Service -import Development.IDE.Core.Shake (IdeState (shakeExtras), - 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 qualified Development.IDE.LSP.LanguageServer as LanguageServer -import Development.IDE.Main.HeapStats (withHeapStats) -import qualified Development.IDE.Main.HeapStats as HeapStats -import Development.IDE.Types.Monitoring (Monitoring) -import qualified Development.IDE.Monitoring.EKG as EKG +import Control.Concurrent (MVar) +import Control.Concurrent.Extra (Chan, + withNumCapabilities) +import Control.Concurrent.STM.Stats (atomically, + dumpSTMStats) +import Control.Exception.Safe (SomeException, + catchAny, + displayException) +import Control.Monad.Extra (concatMapM, unless, + when) +import Control.Monad.Reader (ReaderT) +import qualified Data.Aeson.Encode.Pretty as A +import Data.Default (Default (def)) +import Data.Foldable (traverse_) +import Data.Hashable (hashed) +import qualified Data.HashMap.Strict as HashMap +import Data.List.Extra (intercalate, + isPrefixOf, nub, + nubOrd, partition) +import Data.Maybe (catMaybes, isJust) +import qualified Data.Text as T +import Data.Text.Lazy.Encoding (decodeUtf8) +import qualified Data.Text.Lazy.IO as LT +import Data.Typeable (typeOf) +import Development.IDE (Action, + GhcVersion (..), + Priority (Debug, Error), + Rules, ghcVersion, + hDuplicateTo') +import Development.IDE.Core.Debouncer (Debouncer, + newAsyncDebouncer) +import Development.IDE.Core.FileStore (isWatchSupported) +import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), + registerIdeConfiguration) +import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), + kick, + setFilesOfInterest) +import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), + mainRule) +import qualified Development.IDE.Core.Rules as Rules +import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), + GetHieAst (GetHieAst), + GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + TypeCheck (TypeCheck)) +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, + setupLSP) +import qualified Development.IDE.LSP.LanguageServer as LanguageServer +import Development.IDE.LSP.Server (ReactorChan, + ReactorMessage, + ServerM) +import Development.IDE.Main.HeapStats (withHeapStats) +import qualified Development.IDE.Main.HeapStats as HeapStats +import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry -import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) -import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import qualified Development.IDE.Plugin.HLS as PluginHLS -import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Session (SessionLoadingOptions, - getHieDbLoc, - loadSessionWithOptions, - retryOnSqliteBusy, - runWithDb, - setInitialDynFlags) -import qualified Development.IDE.Session as Session -import Development.IDE.Types.Location (NormalizedUri, - toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, Pretty (pretty), - Priority (Info, Warning), - Recorder, WithPriority, - cmapWithPrio, logWith, - vsep, (<+>)) -import Development.IDE.Types.Options (IdeGhcSession, - IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), - IdeTesting (IdeTesting), - clientSupportsProgress, - defaultIdeOptions, - optModifyDynFlags, - optTesting) -import Development.IDE.Types.Shake (fromKeyType) -import GHC.Conc (getNumProcessors) -import GHC.IO.Encoding (setLocaleEncoding) -import GHC.IO.Handle (hDuplicate) -import HIE.Bios.Cradle (findCradle) -import qualified HieDb.Run as HieDb -import Ide.Plugin.Config (CheckParents (NeverCheck), - Config, checkParents, - checkProject, - getConfigFromNotification) -import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, - pluginsToVSCodeExtensionSchema) -import Ide.PluginUtils (allLspCmdIds', - getProcessID, - idePluginsToPluginDesc, - pluginDescToIdePlugins) -import Ide.Types (IdeCommand (IdeCommand), - IdePlugins, - PluginDescriptor (PluginDescriptor, pluginCli), - PluginId (PluginId), - ipMap) -import qualified Language.LSP.Server as LSP +import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) +import Development.IDE.Plugin.HLS (asGhcIdePlugin) +import qualified Development.IDE.Plugin.HLS as PluginHLS +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Session (SessionLoadingOptions, + getHieDbLoc, + loadSessionWithOptions, + retryOnSqliteBusy, + runWithDb, + setInitialDynFlags) +import qualified Development.IDE.Session as Session +import Development.IDE.Types.Location (NormalizedUri, + toNormalizedFilePath') +import Development.IDE.Types.Logger (Logger, + Pretty (pretty), + Priority (Info, Warning), + Recorder, + WithPriority, + cmapWithPrio, + logWith, vsep, (<+>)) +import Development.IDE.Types.Monitoring (Monitoring) +import Development.IDE.Types.Options (IdeGhcSession, + IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), + IdeTesting (IdeTesting), + clientSupportsProgress, + defaultIdeOptions, + optModifyDynFlags, + optTesting) +import Development.IDE.Types.Shake (WithHieDb, + fromKeyType) +import GHC.Conc (getNumProcessors) +import GHC.IO.Encoding (setLocaleEncoding) +import GHC.IO.Handle (hDuplicate) +import HIE.Bios.Cradle (findCradle) +import qualified HieDb.Run as HieDb +import Ide.Plugin.Config (CheckParents (NeverCheck), + Config, checkParents, + checkProject, + getConfigFromNotification) +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) +import Ide.PluginUtils (allLspCmdIds', + getProcessID, + idePluginsToPluginDesc, + pluginDescToIdePlugins) +import Ide.Types (IdeCommand (IdeCommand), + IdePlugins, + PluginDescriptor (PluginDescriptor, pluginCli), + PluginId (PluginId), + ipMap) +import Language.LSP.Server (LanguageContextEnv) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (Method (Initialize), + RequestMessage) import qualified "list-t" ListT -import Numeric.Natural (Natural) -import Options.Applicative hiding (action) -import qualified StmContainers.Map as STM -import qualified System.Directory.Extra as IO -import System.Exit (ExitCode (ExitFailure), - exitWith) -import System.FilePath (takeExtension, - takeFileName) -import System.IO (BufferMode (LineBuffering, NoBuffering), - Handle, hFlush, - hPutStrLn, - hSetBuffering, - hSetEncoding, stderr, - stdin, stdout, utf8) -import System.Random (newStdGen) -import System.Time.Extra (Seconds, offsetTime, - showDuration) -import Text.Printf (printf) +import Numeric.Natural (Natural) +import Options.Applicative hiding (action) +import qualified StmContainers.Map as STM +import qualified System.Directory.Extra as IO +import System.Exit (ExitCode (ExitFailure), + exitWith) +import System.FilePath (takeExtension, + takeFileName) +import System.IO (BufferMode (LineBuffering, NoBuffering), + Handle, hFlush, + hPutStrLn, + hSetBuffering, + hSetEncoding, stderr, + stdin, stdout, utf8) +import System.Random (newStdGen) +import System.Time.Extra (Seconds, offsetTime, + showDuration) +import Text.Printf (printf) data Log = LogHeapStats !HeapStats.Log @@ -293,7 +313,6 @@ testing recorder logger = , argsIdeOptions = ideOptions } - defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where @@ -328,49 +347,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 gets fully supported - when (ghcVersion == GHC90) $ - log Warning LogOnlyPartialGhc9Support - monitoring <- argsMonitoring - initialise - (cmapWithPrio LogService recorder) - argsDefaultHlsConfig - rules - (Just env) - logger - debouncer - options - withHieDb - hieChan - monitoring + let getIdeState :: 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 gets fully supported + when (ghcVersion == GHC90) $ + log Warning LogOnlyPartialGhc9Support + 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 97ecfa8269..da50696e6a 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -459,10 +459,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 From f52243a9abec886493c33f5d7a99550fc7174308 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 16 Jun 2022 09:24:46 +0200 Subject: [PATCH 2/7] Fix incorrect imports --- exe/Wrapper.hs | 46 ++++++++++++++++++---------------------------- 1 file changed, 18 insertions(+), 28 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index ff39a7c7d7..1a2e05ee83 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -7,8 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -- | This module is based on the hie-wrapper.sh script in -- https://github.com/alanz/vscode-hie-server module Main where @@ -33,7 +31,7 @@ import System.FilePath import System.Info import System.IO -import Control.Concurrent (newChan, tryPutMVar) +import Control.Concurrent (tryPutMVar) import Control.Monad.IO.Class import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader @@ -44,33 +42,25 @@ import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T import Development.IDE.LSP.LanguageServer (runLanguageServer) -import Development.IDE.LSP.Server (ReactorChan, - ReactorMessage) import qualified Development.IDE.Main as Main -import Development.IDE.Types.Logger (WithPriority (WithPriority), - cmapWithPrio, +import Development.IDE.Types.Logger (Logger (Logger), + Priority (..), + WithPriority (WithPriority), + cmapWithPrio, logger_, makeDefaultStderrRecorder) -import qualified Development.IDE.Types.Logger as G +import GHC.Stack (emptyCallStack) import HIE.Bios.Internal.Log (debugm, errorm, logm, warningm) -import qualified Ide.Arguments as IdeArgs import Ide.Plugin.Config (Config) -import Language.LSP.Server (LspM, type (<~>)) +import Language.LSP.Server (LspM) import qualified Language.LSP.Server as LSP import Language.LSP.Types -import qualified System.Directory as IO -import qualified System.Log as L import System.Posix.Process (executeFile) -#if MIN_VERSION_prettyprinter(1,7,0) -import Control.Concurrent.Chan (Chan) -import Development.IDE.Types.Logger (Logger (Logger), - Priority (Info)) -import qualified Development.IDE.Types.Logger as Logger -import GHC.Stack (emptyCallStack) + import Prettyprinter (Pretty (pretty)) -#else -import Data.Text.Prettyprint.Doc (Pretty (pretty), vsep) -#endif + + + -- --------------------------------------------------------------------- @@ -275,7 +265,7 @@ launchErrorLSP :: T.Text -> IO () launchErrorLSP errorMsg = do recorder <- makeDefaultStderrRecorder Nothing Info - let logger = Logger $ \p m -> Logger.logger_ recorder (WithPriority p emptyCallStack (pretty m)) + let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack (pretty m)) let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) logger @@ -317,10 +307,10 @@ launchErrorLSP errorMsg = do exitHandler :: IO () -> LSP.Handlers (ErrorLSPM c) exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit -hlsWrapperLogger :: G.Logger -hlsWrapperLogger = G.Logger $ \pri txt -> +hlsWrapperLogger :: Logger +hlsWrapperLogger = Logger $ \pri txt -> case pri of - G.Debug -> debugm (T.unpack txt) - G.Info -> logm (T.unpack txt) - G.Warning -> warningm (T.unpack txt) - G.Error -> errorm (T.unpack txt) + Debug -> debugm (T.unpack txt) + Info -> logm (T.unpack txt) + Warning -> warningm (T.unpack txt) + Error -> errorm (T.unpack txt) From ee0b93f27a203c14e97e044d4dad487c878e87fc Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 16 Jun 2022 09:29:44 +0200 Subject: [PATCH 3/7] revert import block for smaller diff --- ghcide/src/Development/IDE/Main.hs | 259 +++++++++++++---------------- 1 file changed, 120 insertions(+), 139 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 6076ae10f0..a344aafbcb 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -12,146 +12,127 @@ module Development.IDE.Main ,testing ,Log(..) ) where -import Control.Concurrent (MVar) -import Control.Concurrent.Extra (Chan, - withNumCapabilities) -import Control.Concurrent.STM.Stats (atomically, - dumpSTMStats) -import Control.Exception.Safe (SomeException, - catchAny, - displayException) -import Control.Monad.Extra (concatMapM, unless, - when) -import Control.Monad.Reader (ReaderT) -import qualified Data.Aeson.Encode.Pretty as A -import Data.Default (Default (def)) -import Data.Foldable (traverse_) -import Data.Hashable (hashed) -import qualified Data.HashMap.Strict as HashMap -import Data.List.Extra (intercalate, - isPrefixOf, nub, - nubOrd, partition) -import Data.Maybe (catMaybes, isJust) -import qualified Data.Text as T -import Data.Text.Lazy.Encoding (decodeUtf8) -import qualified Data.Text.Lazy.IO as LT -import Data.Typeable (typeOf) -import Development.IDE (Action, - GhcVersion (..), - Priority (Debug, Error), - Rules, ghcVersion, - hDuplicateTo') -import Development.IDE.Core.Debouncer (Debouncer, - newAsyncDebouncer) -import Development.IDE.Core.FileStore (isWatchSupported) -import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), - registerIdeConfiguration) -import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), - kick, - setFilesOfInterest) -import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), - mainRule) -import qualified Development.IDE.Core.Rules as Rules -import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), - GetHieAst (GetHieAst), - GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - TypeCheck (TypeCheck)) -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, - setupLSP) -import qualified Development.IDE.LSP.LanguageServer as LanguageServer -import Development.IDE.LSP.Server (ReactorChan, - ReactorMessage, - ServerM) -import Development.IDE.Main.HeapStats (withHeapStats) -import qualified Development.IDE.Main.HeapStats as HeapStats -import qualified Development.IDE.Monitoring.EKG as EKG +import Control.Concurrent.Extra (withNumCapabilities) +import Control.Concurrent.STM.Stats (atomically, + dumpSTMStats) +import Control.Exception.Safe (SomeException, catchAny, + displayException) +import Control.Monad.Extra (concatMapM, unless, + when) +import qualified Data.Aeson.Encode.Pretty as A +import Data.Default (Default (def)) +import Data.Foldable (traverse_) +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable (hashed) +import Data.List.Extra (intercalate, isPrefixOf, + nub, nubOrd, partition) +import Data.Maybe (catMaybes, isJust) +import qualified Data.Text as T +import Data.Text.Lazy.Encoding (decodeUtf8) +import qualified Data.Text.Lazy.IO as LT +import Data.Typeable (typeOf) +import Development.IDE (Action, GhcVersion (..), + Priority (Debug, Error), Rules, + ghcVersion, + hDuplicateTo') +import Development.IDE.Core.Debouncer (Debouncer, + newAsyncDebouncer) +import Development.IDE.Core.FileStore (isWatchSupported) +import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), + registerIdeConfiguration) +import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), + kick, + setFilesOfInterest) +import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), + GetHieAst (GetHieAst), + GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + TypeCheck (TypeCheck)) +import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), + mainRule) +import qualified Development.IDE.Core.Rules as Rules +import Development.IDE.Core.Service (initialise, runAction) +import qualified Development.IDE.Core.Service as Service +import Development.IDE.Core.Shake (IdeState (shakeExtras), + 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 qualified Development.IDE.LSP.LanguageServer as LanguageServer +import Development.IDE.Main.HeapStats (withHeapStats) +import qualified Development.IDE.Main.HeapStats as HeapStats +import Development.IDE.Types.Monitoring (Monitoring) +import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry -import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) -import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import qualified Development.IDE.Plugin.HLS as PluginHLS -import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Session (SessionLoadingOptions, - getHieDbLoc, - loadSessionWithOptions, - retryOnSqliteBusy, - runWithDb, - setInitialDynFlags) -import qualified Development.IDE.Session as Session -import Development.IDE.Types.Location (NormalizedUri, - toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, - Pretty (pretty), - Priority (Info, Warning), - Recorder, - WithPriority, - cmapWithPrio, - logWith, vsep, (<+>)) -import Development.IDE.Types.Monitoring (Monitoring) -import Development.IDE.Types.Options (IdeGhcSession, - IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), - IdeTesting (IdeTesting), - clientSupportsProgress, - defaultIdeOptions, - optModifyDynFlags, - optTesting) -import Development.IDE.Types.Shake (WithHieDb, - fromKeyType) -import GHC.Conc (getNumProcessors) -import GHC.IO.Encoding (setLocaleEncoding) -import GHC.IO.Handle (hDuplicate) -import HIE.Bios.Cradle (findCradle) -import qualified HieDb.Run as HieDb -import Ide.Plugin.Config (CheckParents (NeverCheck), - Config, checkParents, - checkProject, - getConfigFromNotification) -import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, - pluginsToVSCodeExtensionSchema) -import Ide.PluginUtils (allLspCmdIds', - getProcessID, - idePluginsToPluginDesc, - pluginDescToIdePlugins) -import Ide.Types (IdeCommand (IdeCommand), - IdePlugins, - PluginDescriptor (PluginDescriptor, pluginCli), - PluginId (PluginId), - ipMap) -import Language.LSP.Server (LanguageContextEnv) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (Method (Initialize), - RequestMessage) +import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) +import Development.IDE.Plugin.HLS (asGhcIdePlugin) +import qualified Development.IDE.Plugin.HLS as PluginHLS +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Session (SessionLoadingOptions, + getHieDbLoc, + loadSessionWithOptions, + retryOnSqliteBusy, + runWithDb, + setInitialDynFlags) +import qualified Development.IDE.Session as Session +import Development.IDE.Types.Location (NormalizedUri, + toNormalizedFilePath') +import Development.IDE.Types.Logger (Logger, Pretty (pretty), + Priority (Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + vsep, (<+>)) +import Development.IDE.Types.Options (IdeGhcSession, + IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), + IdeTesting (IdeTesting), + clientSupportsProgress, + defaultIdeOptions, + optModifyDynFlags, + optTesting) +import Development.IDE.Types.Shake (fromKeyType) +import GHC.Conc (getNumProcessors) +import GHC.IO.Encoding (setLocaleEncoding) +import GHC.IO.Handle (hDuplicate) +import HIE.Bios.Cradle (findCradle) +import qualified HieDb.Run as HieDb +import Ide.Plugin.Config (CheckParents (NeverCheck), + Config, checkParents, + checkProject, + getConfigFromNotification) +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) +import Ide.PluginUtils (allLspCmdIds', + getProcessID, + idePluginsToPluginDesc, + pluginDescToIdePlugins) +import Ide.Types (IdeCommand (IdeCommand), + IdePlugins, + PluginDescriptor (PluginDescriptor, pluginCli), + PluginId (PluginId), + ipMap) +import qualified Language.LSP.Server as LSP import qualified "list-t" ListT -import Numeric.Natural (Natural) -import Options.Applicative hiding (action) -import qualified StmContainers.Map as STM -import qualified System.Directory.Extra as IO -import System.Exit (ExitCode (ExitFailure), - exitWith) -import System.FilePath (takeExtension, - takeFileName) -import System.IO (BufferMode (LineBuffering, NoBuffering), - Handle, hFlush, - hPutStrLn, - hSetBuffering, - hSetEncoding, stderr, - stdin, stdout, utf8) -import System.Random (newStdGen) -import System.Time.Extra (Seconds, offsetTime, - showDuration) -import Text.Printf (printf) +import Numeric.Natural (Natural) +import Options.Applicative hiding (action) +import qualified StmContainers.Map as STM +import qualified System.Directory.Extra as IO +import System.Exit (ExitCode (ExitFailure), + exitWith) +import System.FilePath (takeExtension, + takeFileName) +import System.IO (BufferMode (LineBuffering, NoBuffering), + Handle, hFlush, + hPutStrLn, + hSetBuffering, + hSetEncoding, stderr, + stdin, stdout, utf8) +import System.Random (newStdGen) +import System.Time.Extra (Seconds, offsetTime, + showDuration) +import Text.Printf (printf) data Log = LogHeapStats !HeapStats.Log @@ -347,7 +328,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re t <- offsetTime log Info LogLspStart - let getIdeState :: LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState + let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState getIdeState env rootPath withHieDb hieChan = do traverse_ IO.setCurrentDirectory rootPath t <- t From d2dd94ea2f9e8135f266983ec6de8dfd7ce07a04 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 16 Jun 2022 09:32:37 +0200 Subject: [PATCH 4/7] add missing imports --- ghcide/src/Development/IDE/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a344aafbcb..09284a484b 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -55,11 +55,11 @@ import Development.IDE.Core.Service (initialise, runAction) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), ShakeExtras (state), - shakeSessionInit, uses) + shakeSessionInit, uses, IndexQueue) 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 @@ -92,7 +92,7 @@ import Development.IDE.Types.Options (IdeGhcSession, defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (fromKeyType) +import Development.IDE.Types.Shake (fromKeyType, WithHieDb) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) From 9712b83467ff58d71febe0739a2e02cf44755285 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 16 Jun 2022 21:17:01 +0200 Subject: [PATCH 5/7] Fix: callProcess on win32 machines not called --- exe/Wrapper.hs | 74 ++++++++++++++++++++++++-------------------------- 1 file changed, 36 insertions(+), 38 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 1a2e05ee83..48e942f054 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -12,55 +12,50 @@ module Main where import Control.Monad.Extra -import Data.Char (isSpace) +import Data.Char (isSpace) import Data.Default import Data.Foldable import Data.List import Data.Void -import qualified Development.IDE.Session as Session -import qualified HIE.Bios.Environment as HieBios +import qualified Development.IDE.Session as Session +import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types import Ide.Arguments -import Ide.Version (findProgramVersions, - hlsVersion, - showProgramVersionOfInterest) +import Ide.Version import System.Directory import System.Environment import System.Exit import System.FilePath -import System.Info import System.IO - -import Control.Concurrent (tryPutMVar) -import Control.Monad.IO.Class -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Reader -import Control.Monad.Trans.Except (ExceptT, runExceptT, - throwE) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, listToMaybe) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import System.Info +#ifndef mingw32_HOST_OS +import System.Posix.Process (executeFile) +#else +import System.Process +#endif +import qualified Data.Map.Strict as Map +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 qualified Development.IDE.Main as Main -import Development.IDE.Types.Logger (Logger (Logger), - Priority (..), - WithPriority (WithPriority), - cmapWithPrio, logger_, - makeDefaultStderrRecorder) -import GHC.Stack (emptyCallStack) -import HIE.Bios.Internal.Log (debugm, errorm, logm, - warningm) -import Ide.Plugin.Config (Config) -import Language.LSP.Server (LspM) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import System.Posix.Process (executeFile) - -import Prettyprinter (Pretty (pretty)) - - - +import HIE.Bios.Internal.Log -- --------------------------------------------------------------------- @@ -155,7 +150,9 @@ launchHaskellLanguageServer parsedArgs = do Just e -> do liftIO $ hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e - +#ifdef mingw32_HOST_OS + callProcess e args +#else let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle @@ -170,6 +167,7 @@ launchHaskellLanguageServer parsedArgs = do 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 From 88168876a5da7c93cb264a3e9b82816583de23c7 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 16 Jun 2022 22:21:53 +0200 Subject: [PATCH 6/7] import container only on win32 --- exe/Wrapper.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 48e942f054..7d0b17bda7 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -30,10 +30,10 @@ import System.IO import System.Info #ifndef mingw32_HOST_OS import System.Posix.Process (executeFile) +import qualified Data.Map.Strict as Map #else import System.Process #endif -import qualified Data.Map.Strict as Map import qualified Data.Text.IO as T import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import qualified Data.Text as T From 5ad4ef4089ae9d16ebc33bb1d723b9dec0db8c1d Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 17 Jun 2022 00:06:18 +0200 Subject: [PATCH 7/7] add missing liftIO --- exe/Wrapper.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 7d0b17bda7..23cc153215 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -151,7 +151,7 @@ launchHaskellLanguageServer parsedArgs = do liftIO $ 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