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.
haskell · Jun 16, 2023 · 187003c · 187003c
1 parent 139dcf5
commit 187003c
Show file tree

Hide file tree

Showing 3 changed files with 107 additions and 69 deletions.
diff --git a/exe/Main.hs b/exe/Main.hs
@@ -1,7 +1,9 @@
 -- 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                ((&&&))
@@ -10,13 +12,14 @@ import           Data.Function                ((&))
 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)
+                                               withFileRecorder)
 import qualified Development.IDE.Types.Logger as Logger
 import qualified HlsPlugins                   as Plugins
 import           Ide.Arguments                (Arguments (..),
@@ -30,7 +33,11 @@ import           Ide.Types                    (PluginDescriptor (pluginNotificat
                                                mkPluginNotificationHandler)
 import           Language.LSP.Server          as LSP
 import           Language.LSP.Types           as LSP
-import           Prettyprinter                (Pretty (pretty), vsep)
+import           Prettyprinter                (Pretty (pretty), vcat, vsep)
+import           Control.Exception            (displayException)
+import           Data.Bifunctor               (first)
+import           Data.Functor                 ((<&>))
+import           Data.Maybe                   (catMaybes)
 
 data Log
   = LogIdeMain IdeMain.Log
@@ -43,13 +50,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 +79,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 +116,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
@@ -16,7 +16,7 @@ module Development.IDE.Types.Logger
   , cmap
   , cmapIO
   , cfilter
-  , withDefaultRecorder
+  , withFileRecorder
   , makeDefaultStderrRecorder
   , makeDefaultHandleRecorder
   , LoggingColumn(..)
@@ -156,35 +156,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
@@ -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)"