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)" diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 24af9869b4..f2e1a4d376 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -6,28 +6,23 @@ 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 -import Test.Hls.Command {-# ANN module ("HLint: ignore Reduce duplication"::String) #-} @@ -35,30 +30,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" [