From caad5cfff0e37c88d6578b40d91c54b6a0720200 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 24 Mar 2021 19:55:18 +0000 Subject: [PATCH] Configurable I/O handles --- .../src/Development/IDE/LSP/LanguageServer.hs | 22 ++++---------- ghcide/src/Development/IDE/Main.hs | 30 ++++++++++++++++--- 2 files changed, 31 insertions(+), 21 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index fb0062f6e2..bc8a121c8b 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -26,7 +26,6 @@ import qualified Data.Text as T import qualified Development.IDE.GHC.Util as Ghcide import Development.IDE.LSP.Server import Development.IDE.Session (runWithDb) -import GHC.IO.Handle (hDuplicate) import Ide.Types (traceWithSpan) import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -48,25 +47,14 @@ import System.IO.Unsafe (unsafeInterleaveIO) runLanguageServer :: forall config. (Show config) => LSP.Options + -> Handle -- input + -> Handle -- output -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> (IdeState -> Value -> IO (Either T.Text config)) -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState) -> IO () -runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeState = do - -- Move stdout to another file descriptor and duplicate stderr - -- to stdout. This guards against stray prints from corrupting the JSON-RPC - -- message stream. - newStdout <- hDuplicate stdout - stderr `Ghcide.hDuplicateTo'` stdout - hSetBuffering stderr NoBuffering - hSetBuffering stdout NoBuffering - - -- Print out a single space to assert that the above redirection works. - -- This is interleaved with the logger, hence we just print a space here in - -- order not to mess up the output too much. Verified that this breaks - -- the language server tests without the redirection. - putStr " " >> hFlush stdout +runLanguageServer options inH outH getHieDbLoc onConfigurationChange userHandlers getIdeState = do -- These barriers are signaled when the threads reading from these chans exit. -- This should not happen but if it does, we will make sure that the whole server @@ -126,8 +114,8 @@ runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeS void $ waitAnyCancel =<< traverse async [ void $ LSP.runServerWithHandles - stdin - newStdout + inH + outH serverDefinition , void $ waitBarrier clientMsgBarrier ] diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 4695233bc8..6efc21c17b 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -14,7 +14,8 @@ import Data.Maybe (catMaybes, fromMaybe, isJust) import qualified Data.Text as T import qualified Data.Text.IO as T -import Development.IDE (Action, Rules) +import Development.IDE (Action, Rules, + hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) import Development.IDE.Core.FileStore (makeVFSHandle) @@ -54,6 +55,7 @@ import Development.IDE.Types.Options (IdeGhcSession, import Development.IDE.Types.Shake (Key (Key)) import Development.Shake (action) import GHC.IO.Encoding (setLocaleEncoding) +import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) import Ide.Plugin.Config (CheckParents (NeverCheck), Config, @@ -68,11 +70,12 @@ import System.Exit (ExitCode (ExitFailure), exitWith) import System.FilePath (takeExtension, takeFileName) -import System.IO (BufferMode (LineBuffering), +import System.IO (BufferMode (LineBuffering, NoBuffering), + Handle, hFlush, hPutStrLn, hSetBuffering, hSetEncoding, stderr, - stdout, utf8) + stdin, stdout, utf8) import System.Time.Extra (offsetTime, showDuration) import Text.Printf (printf) @@ -90,6 +93,8 @@ data Arguments = Arguments , argsDefaultHlsConfig :: Config , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project , argsDebouncer :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics + , argsHandleIn :: IO Handle + , argsHandleOut :: IO Handle } instance Default Arguments where @@ -106,6 +111,21 @@ instance Default Arguments where , argsDefaultHlsConfig = def , argsGetHieDbLoc = getHieDbLoc , argsDebouncer = newAsyncDebouncer + , argsHandleIn = pure stdin + , argsHandleOut = do + -- Move stdout to another file descriptor and duplicate stderr + -- to stdout. This guards against stray prints from corrupting the JSON-RPC + -- message stream. + newStdout <- hDuplicate stdout + stderr `hDuplicateTo'` stdout + hSetBuffering stdout NoBuffering + + -- Print out a single space to assert that the above redirection works. + -- This is interleaved with the logger, hence we just print a space here in + -- order not to mess up the output too much. Verified that this breaks + -- the language server tests without the redirection. + putStr " " >> hFlush stdout + return newStdout } -- | Cheap stderr logger that relies on LineBuffering @@ -130,13 +150,15 @@ defaultMain Arguments{..} = do rules = argsRules >> pluginRules plugins debouncer <- argsDebouncer + inH <- argsHandleIn + outH <- argsHandleOut case argFiles of Nothing -> do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer options argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do + runLanguageServer options inH outH argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t