Configurable I/O handles (#1617)

Author: pepeiborra

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
         ]

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