Add arguments to direct logs to various locations (haskell#3665)

* 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. * Remove weird test * Fix warning

Author: michaelpj

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

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

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)"

test/functional/Config.hs

@@ -6,59 +6,33 @@
 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) #-}
 
 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"
  [