From 1e2e98631acb2ab06b1e87471ae96fcb77eef910 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Mon, 12 Jun 2023 13:19:52 +0100 Subject: [PATCH 1/3] Add arguments to direct logs to various locations This adds arguments to HLS to allow the user to select whether to send logs to any or all of: - a file - stderr - the client Importantly, we can toggle off the default stderr logging, so the vscode extension can turn it off to avoid the double logging that arises from logging to both the client and stderr. I've set the default to _not_ log to the client. This is a change of behaviour (today we log to the client by default), but I think it gives the best experience by default, since most clients do show stderr output somewhere, and then we probably want to make a case-by-case decision on whether to use the client logging instead. --- exe/Main.hs | 94 +++++++++++++--------- ghcide/src/Development/IDE/Types/Logger.hs | 35 +++----- src/Ide/Arguments.hs | 50 +++++++++--- 3 files changed, 107 insertions(+), 72 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index d0597e02ee..ee46a7cbcf 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,22 +1,26 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main(main) where -import Control.Arrow ((&&&)) +import Control.Exception (displayException) import Control.Monad.IO.Class (liftIO) +import Data.Bifunctor (first) import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Maybe (catMaybes) import Data.Text (Text) -import qualified Development.IDE.Main as GhcideMain import Development.IDE.Types.Logger (Doc, Priority (Error, Info), + Recorder, WithPriority (WithPriority, priority), cfilter, cmapWithPrio, defaultLayoutOptions, - layoutPretty, + layoutPretty, logWith, makeDefaultStderrRecorder, - payload, renderStrict, - withDefaultRecorder) + renderStrict, withFileRecorder) import qualified Development.IDE.Types.Logger as Logger import qualified HlsPlugins as Plugins import Ide.Arguments (Arguments (..), @@ -30,7 +34,7 @@ import Ide.Types (PluginDescriptor (pluginNotifica mkPluginNotificationHandler) import Language.LSP.Protocol.Message as LSP import Language.LSP.Server as LSP -import Prettyprinter (Pretty (pretty), vsep) +import Prettyprinter (Pretty (pretty), vcat, vsep) data Log = LogIdeMain IdeMain.Log @@ -43,13 +47,27 @@ instance Pretty Log where main :: IO () main = do + stderrRecorder <- makeDefaultStderrRecorder Nothing -- plugin cli commands use stderr logger for now unless we change the args -- parser to get logging arguments first or do more complicated things - pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing + let pluginCliRecorder = cmapWithPrio pretty stderrRecorder args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder)) - (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder - (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder + -- Recorder that logs to the LSP client with logMessage + (lspLogRecorder, cb1) <- + Logger.withBacklog Logger.lspClientLogRecorder + <&> first (cmapWithPrio renderDoc) + -- Recorder that logs to the LSP client with showMessage + (lspMessageRecorder, cb2) <- + Logger.withBacklog Logger.lspClientMessageRecorder + <&> first (cmapWithPrio renderDoc) + -- Recorder that logs Error severity logs to the client with showMessage and some extra text + let lspErrorMessageRecorder = lspMessageRecorder + & cfilter (\WithPriority{ priority } -> priority >= Error) + & cmapWithPrio (\msg -> vsep + ["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): " + , msg + ]) -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback") @@ -58,28 +76,35 @@ main = do liftIO $ (cb1 <> cb2) env } - let (argsTesting, minPriority, logFilePath) = + let (minPriority, logFilePath, logStderr, logClient) = case args of - Ghcide GhcideArguments{ argsTesting, argsLogLevel, argsLogFile} -> - (argsTesting, argsLogLevel, argsLogFile) - _ -> (False, Info, Nothing) + Ghcide GhcideArguments{ argsLogLevel, argsLogFile, argsLogStderr, argsLogClient} -> + (argsLogLevel, argsLogFile, argsLogStderr, argsLogClient) + _ -> (Info, Nothing, True, False) - withDefaultRecorder logFilePath Nothing $ \textWithPriorityRecorder -> do + -- Adapter for withFileRecorder to handle the case where we don't want to log to a file + let withLogFileRecorder action = case logFilePath of + Just p -> withFileRecorder p Nothing $ \case + Left e -> do + let exceptionMessage = pretty $ displayException e + let message = vcat [exceptionMessage, "Couldn't open log file; not logging to it."] + logWith stderrRecorder Error message + action Nothing + Right r -> action (Just r) + Nothing -> action Nothing + + withLogFileRecorder $ \logFileRecorder -> do let - recorder = cmapWithPrio (pretty &&& id) $ mconcat - [textWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmapWithPrio fst - , lspMessageRecorder - & cfilter (\WithPriority{ priority } -> priority >= Error) - & cmapWithPrio (renderDoc . fst) - , lspLogRecorder - & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions . fst) - -- do not log heap stats to the LSP log as they interfere with the - -- ability of lsp-test to detect a stuck server in tests and benchmarks - & if argsTesting then cfilter (not . heapStats . snd . payload) else id - ] + lfr = logFileRecorder + ser = if logStderr then Just stderrRecorder else Nothing + lemr = Just lspErrorMessageRecorder + llr = if logClient then Just lspLogRecorder else Nothing + recorder :: Recorder (WithPriority Log) = + [lfr, ser, lemr, llr] + & catMaybes + & mconcat + & cmapWithPrio pretty + & cfilter (\WithPriority{ priority } -> priority >= minPriority) plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder) defaultMain @@ -88,14 +113,7 @@ main = do (plugins <> pluginDescToIdePlugins [lspRecorderPlugin]) renderDoc :: Doc a -> Text -renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep - ["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): " - ,d - ] +renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions d issueTrackerUrl :: Doc a issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" - -heapStats :: Log -> Bool -heapStats (LogIdeMain (IdeMain.LogIDEMain (GhcideMain.LogHeapStats _))) = True -heapStats _ = False diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 5869237fbe..aec4fa3c0a 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -16,7 +16,7 @@ module Development.IDE.Types.Logger , cmap , cmapIO , cfilter - , withDefaultRecorder + , withFileRecorder , makeDefaultStderrRecorder , makeDefaultHandleRecorder , LoggingColumn(..) @@ -157,35 +157,22 @@ makeDefaultStderrRecorder columns = do lock <- liftIO newLock makeDefaultHandleRecorder columns lock stderr --- | If no path given then use stderr, otherwise use file. -withDefaultRecorder +withFileRecorder :: MonadUnliftIO m - => Maybe FilePath - -- ^ Log file path. `Nothing` uses stderr + => FilePath + -- ^ Log file path. -> Maybe [LoggingColumn] -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns` - -> (Recorder (WithPriority (Doc d)) -> m a) - -- ^ action given a recorder + -> (Either IOException (Recorder (WithPriority (Doc d))) -> m a) + -- ^ action given a recorder, or the exception if we failed to open the file -> m a -withDefaultRecorder path columns action = do +withFileRecorder path columns action = do lock <- liftIO newLock let makeHandleRecorder = makeDefaultHandleRecorder columns lock - case path of - Nothing -> do - recorder <- makeHandleRecorder stderr - let message = "No log file specified; using stderr." - logWith recorder Info message - action recorder - Just path -> do - fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) - case fileHandle of - Left e -> do - recorder <- makeHandleRecorder stderr - let exceptionMessage = pretty $ displayException e - let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."] - logWith recorder Warning message - action recorder - Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle) + fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) + case fileHandle of + Left e -> action $ Left e + Right fileHandle -> finally ((Right <$> makeHandleRecorder fileHandle) >>= action) (liftIO $ hClose fileHandle) makeDefaultHandleRecorder :: MonadIO m diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 8c03f1b0fc..176b896a27 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -40,14 +40,16 @@ data Arguments | PrintLibDir data GhcideArguments = GhcideArguments - {argsCommand :: Command - ,argsCwd :: Maybe FilePath - ,argsShakeProfiling :: Maybe FilePath - ,argsTesting :: Bool - ,argsExamplePlugin :: Bool + { argsCommand :: Command + , argsCwd :: Maybe FilePath + , argsShakeProfiling :: Maybe FilePath + , argsTesting :: Bool + , argsExamplePlugin :: Bool , argsLogLevel :: Priority , argsLogFile :: Maybe String -- ^ the minimum log level to show + , argsLogStderr :: Bool + , argsLogClient :: Bool , argsThreads :: Int , argsProjectGhcVersion :: Bool } deriving Show @@ -138,12 +140,40 @@ arguments plugins = GhcideArguments <> help "Sets the log level to Debug, alias for '--log-level Debug'" ) ) - <*> optional (strOption - (long "logfile" - <> short 'l' + -- This option is a little inconsistent with the other log options, since + -- it's not a boolean and there is no way to turn it off. That's okay + -- since the default is off. + <*> (optional (strOption + ( long "log-file" <> metavar "LOGFILE" - <> help "File to log to, defaults to stdout" - )) + <> help "Send logs to a file" + )) <|> (optional (strOption + ( long "logfile" + <> metavar "LOGFILE" + <> help "Send logs to a file" + -- deprecated alias so users don't need to update their CLI calls + -- immediately + <> internal + ))) + ) + -- Boolean option so we can toggle the default in a consistent way + <*> option auto + ( long "log-stderr" + <> help "Send logs to stderr" + <> metavar "BOOL" + <> value True + <> showDefault + ) + -- Boolean option so we can toggle the default in a consistent way + <*> option auto + ( long "log-client" + <> help "Send logs to the client using the window/logMessage LSP method" + <> metavar "BOOL" + -- This is off by default, since some clients will show duplicate logs + -- if we log both to stderr and the client + <> value False + <> showDefault + ) <*> option auto (short 'j' <> help "Number of threads (0: automatic)" From fc13e05a936b748590952fbf49c27cb0f776a796 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Tue, 20 Jun 2023 18:18:14 +0100 Subject: [PATCH 2/3] Remove weird test --- test/functional/Config.hs | 24 +----------------------- 1 file changed, 1 insertion(+), 23 deletions(-) diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 24af9869b4..cb8f381cc1 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -27,7 +27,6 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Test as Test import System.FilePath (()) import Test.Hls -import Test.Hls.Command {-# ANN module ("HLint: ignore Reduce duplication"::String) #-} @@ -35,30 +34,9 @@ tests :: TestTree tests = testGroup "plugin config" [ -- Note: there are more comprehensive tests over config in hls-hlint-plugin -- TODO: Add generic tests over some example plugin - configParsingTests, genericConfigTests + genericConfigTests ] -configParsingTests :: TestTree -configParsingTests = testGroup "config parsing" - [ testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do - let config = object [] - sendConfigurationChanged (toJSON config) - - -- Send custom request so server returns a response to prevent blocking - void $ sendNotification (SMethod_CustomMethod (Proxy @"non-existent-method")) Null - - logNot <- skipManyTill Test.anyMessage (message SMethod_WindowLogMessage) - - liftIO $ (logNot ^. L.params . L.type_) > MessageType_Error - || "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message) - @? "Server sends logMessage with MessageType = Error" - ] - - where - runConfigSession :: FilePath -> Session a -> IO a - runConfigSession subdir = - failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata" subdir) - genericConfigTests :: TestTree genericConfigTests = testGroup "generic plugin config" [ From 4129c813d31bcd429dc5190c2bd250d1ec5ee8dd Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Fri, 23 Jun 2023 19:15:12 +0100 Subject: [PATCH 3/3] Fix warning --- test/functional/Config.hs | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/test/functional/Config.hs b/test/functional/Config.hs index cb8f381cc1..f2e1a4d376 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -6,26 +6,22 @@ module Config (tests) where import Control.DeepSeq -import Control.Lens hiding (List, (.=)) import Control.Monad import Data.Aeson import Data.Hashable -import qualified Data.HashMap.Strict as HM -import qualified Data.Map as Map -import Data.Proxy -import qualified Data.Text as T -import Data.Typeable (Typeable) -import Development.IDE (RuleResult, action, define, - getFilesOfInterestUntracked, - getPluginConfigAction, - ideErrorText, uses_) -import Development.IDE.Test (expectDiagnostics) +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as Map +import Data.Typeable (Typeable) +import Development.IDE (RuleResult, action, define, + getFilesOfInterestUntracked, + getPluginConfigAction, ideErrorText, + uses_) +import Development.IDE.Test (expectDiagnostics) import GHC.Generics import Ide.Plugin.Config import Ide.Types -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Test as Test -import System.FilePath (()) +import Language.LSP.Test as Test +import System.FilePath (()) import Test.Hls {-# ANN module ("HLint: ignore Reduce duplication"::String) #-}