no longer silence stderr

pepeiborra · pepeiborra · commit 6b29d09de1b9 · 2021-10-03T22:37:43.000+01:00
Instead, send all ghcide output through the logger and keep stderr open for fatals
diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs
@@ -102,7 +102,7 @@ data SessionLoadingOptions = SessionLoadingOptions
   --   or 'Nothing' to respect the cradle setting
   , getCacheDirs           :: String -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
-  , getInitialGhcLibDir    :: FilePath -> IO (Maybe LibDir)
+  , getInitialGhcLibDir    :: Logger -> FilePath -> IO (Maybe LibDir)
   , fakeUid                :: UnitId
     -- ^ unit id used to tag the internal component built by ghcide
     --   To reuse external interface files the unit ids must match,
@@ -140,11 +140,11 @@ loadWithImplicitCradle mHieYaml rootDir = do
     Just yaml -> HieBios.loadCradle yaml
     Nothing   -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir
 
-getInitialGhcLibDirDefault :: FilePath -> IO (Maybe LibDir)
-getInitialGhcLibDirDefault rootDir = do
+getInitialGhcLibDirDefault :: Logger -> FilePath -> IO (Maybe LibDir)
+getInitialGhcLibDirDefault logger rootDir = do
   hieYaml <- findCradle def rootDir
   cradle <- loadCradle def hieYaml rootDir
-  hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
+  logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle
   libDirRes <- getRuntimeGhcLibDir cradle
   case libDirRes of
       CradleSuccess libdir -> pure $ Just $ LibDir libdir
@@ -156,9 +156,9 @@ getInitialGhcLibDirDefault rootDir = do
         pure Nothing
 
 -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
-setInitialDynFlags :: FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
-setInitialDynFlags rootDir SessionLoadingOptions{..} = do
-  libdir <- getInitialGhcLibDir rootDir
+setInitialDynFlags :: Logger -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
+setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do
+  libdir <- getInitialGhcLibDir logger rootDir
   dynFlags <- mapM dynFlagsForPrinting libdir
   mapM_ setUnsafeGlobalDynFlags dynFlags
   pure libdir
@@ -167,8 +167,8 @@ setInitialDynFlags rootDir SessionLoadingOptions{..} = do
 -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
 -- by a worker thread using a dedicated database connection.
 -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
-runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
-runWithDb fp k = do
+runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
+runWithDb logger fp k = do
   -- Delete the database if it has an incompatible schema version
   withHieDb fp (const $ pure ())
     `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp
@@ -186,9 +186,9 @@ runWithDb fp k = do
         k <- atomically $ readTQueue chan
         k db
           `Safe.catch` \e@SQLError{} -> do
-            hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e
+            logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e
           `Safe.catchAny` \e -> do
-            hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e
+            logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e
 
 
 getHieDbLoc :: FilePath -> IO FilePath
@@ -361,7 +361,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
             res <- loadDLL hscEnv "libm.so.6"
             case res of
               Nothing -> pure ()
-              Just err -> hPutStrLn stderr $
+              Just err -> logDebug logger $ T.pack $
                 "Error dynamically loading libm.so.6:\n" <> err
 
           -- Make a map from unit-id to DynFlags, this is used when trying to
@@ -425,7 +425,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
            let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
                          <> " (for " <> T.pack lfp <> ")"
            eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
-              cradleToOptsAndLibDir cradle cfp
+              cradleToOptsAndLibDir logger cradle cfp
 
            logDebug logger $ T.pack ("Session loading result: " <> show eopts)
            case eopts of
@@ -495,11 +495,11 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 -- This then builds dependencies or whatever based on the cradle, gets the
 -- GHC options/dynflags needed for the session and the GHC library directory
 
-cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
+cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath
                       -> IO (Either [CradleError] (ComponentOptions, FilePath))
-cradleToOptsAndLibDir cradle file = do
+cradleToOptsAndLibDir logger cradle file = do
     -- Start off by getting the session options
-    hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
+    logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle
     cradleRes <- HieBios.getCompilerOptions file cradle
     case cradleRes of
         CradleSuccess r -> do
diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs
@@ -141,7 +141,8 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
                         T.pack $ "Fatal error in server thread: " <> show e
                     exitClientMsg
                 handleServerException _ = pure ()
-            _ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do
+                logger = ideLogger ide
+            _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do
               putMVar dbMVar (hiedb,hieChan)
               forever $ do
                 msg <- readChan clientMsgChan
diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs
@@ -63,7 +63,8 @@ import           Development.IDE.Session               (SessionLoadingOptions,
                                                         setInitialDynFlags)
 import           Development.IDE.Types.Location        (NormalizedUri,
                                                         toNormalizedFilePath')
-import           Development.IDE.Types.Logger          (Logger (Logger))
+import           Development.IDE.Types.Logger          (Logger (Logger),
+                                                        logDebug, logInfo)
 import           Development.IDE.Types.Options         (IdeGhcSession,
                                                         IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
                                                         IdeTesting (IdeTesting),
@@ -251,20 +252,20 @@ defaultMain Arguments{..} = do
             LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins
         LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do
             t <- offsetTime
-            hPutStrLn stderr "Starting LSP server..."
-            hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
+            logInfo logger "Starting LSP server..."
+            logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
             runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
                 traverse_ IO.setCurrentDirectory rootPath
                 t <- t
-                hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
+                logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration 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 dir argsSessionLoadingOptions
-                        `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
+                    setInitialDynFlags logger dir argsSessionLoadingOptions
+                        `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
 
 
                 sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir
@@ -273,7 +274,7 @@ defaultMain Arguments{..} = do
 
                 -- disable runSubset if the client doesn't support watched files
                 runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported
-                hPutStrLn stderr $ "runSubset: " <> show runSubset
+                logDebug logger $ T.pack $ "runSubset: " <> show runSubset
 
                 let options = def_options
                             { optReportProgress = clientSupportsProgress caps
@@ -299,7 +300,7 @@ defaultMain Arguments{..} = do
         Check argFiles -> do
           dir <- IO.getCurrentDirectory
           dbLoc <- getHieDbLoc dir
-          runWithDb dbLoc $ \hiedb hieChan -> do
+          runWithDb logger dbLoc $ \hiedb hieChan -> do
             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
             hSetEncoding stdout utf8
             hSetEncoding stderr utf8
@@ -363,14 +364,14 @@ defaultMain Arguments{..} = do
         Db dir opts cmd -> do
             dbLoc <- getHieDbLoc dir
             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
-            mlibdir <- setInitialDynFlags dir def
+            mlibdir <- setInitialDynFlags logger dir def
             case mlibdir of
                 Nothing     -> exitWith $ ExitFailure 1
                 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd
 
         Custom projectRoot (IdeCommand c) -> do
           dbLoc <- getHieDbLoc projectRoot
-          runWithDb dbLoc $ \hiedb hieChan -> do
+          runWithDb logger dbLoc $ \hiedb hieChan -> do
             vfs <- makeVFSHandle
             sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."
             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs
@@ -53,16 +53,14 @@ import           Ide.Plugin.Config               (Config, formattingProvider)
 import           Ide.PluginUtils                 (idePluginsToPluginDesc, pluginDescToIdePlugins)
 import           Ide.Types
 import           Language.LSP.Test
-import           Language.LSP.Types                hiding
-                                                   (SemanticTokenAbsolute (length, line),
-                                                    SemanticTokenRelative (length),
-                                                    SemanticTokensEdit (_start))
-import           Language.LSP.Types.Capabilities   (ClientCapabilities)
-import           System.Directory                  (getCurrentDirectory,
-                                                    setCurrentDirectory)
-import           System.Environment.Blank          (getEnvDefault)
+import           Language.LSP.Types              hiding
+                                                 (SemanticTokenAbsolute (length, line),
+                                                  SemanticTokenRelative (length),
+                                                  SemanticTokensEdit (_start))
+import           Language.LSP.Types.Capabilities (ClientCapabilities)
+import           System.Directory                (getCurrentDirectory,
+                                                  setCurrentDirectory)
 import           System.FilePath
-import           System.IO.Extra
 import           System.IO.Unsafe                (unsafePerformIO)
 import           System.Process.Extra            (createPipe)
 import           System.Time.Extra
@@ -133,22 +131,6 @@ runSessionWithServerFormatter plugin formatter =
     def
     fullCaps
 
--- | Run an action, with stderr silenced
-silenceStderr :: IO a -> IO a
-silenceStderr action = do
-  showStderr <- getEnvDefault "LSP_TEST_LOG_STDERR" "0"
-  case showStderr of
-    "0" -> withTempFile $ \temp ->
-      bracket (openFile temp ReadWriteMode) hClose $ \h -> do
-        old <- hDuplicate stderr
-        buf <- hGetBuffering stderr
-        h `hDuplicateTo'` stderr
-        action `finally` do
-          old `hDuplicateTo'` stderr
-          hSetBuffering stderr buf
-          hClose old
-    _ -> action
-
 -- | Restore cwd after running an action
 keepCurrentDirectory :: IO a -> IO a
 keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const
@@ -171,7 +153,7 @@ runSessionWithServer' ::
   FilePath ->
   Session a ->
   IO a
-runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ silenceStderr $ do
+runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do
   (inR, inW) <- createPipe
   (outR, outW) <- createPipe
   server <-
