Skip to content

Commit 187003c

Browse files
michaelpjmichaelpj
committed
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.
1 parent 139dcf5 commit 187003c

File tree

3 files changed

+107
-69
lines changed

3 files changed

+107
-69
lines changed

‎exe/Main.hs

Lines changed: 56 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,9 @@
11
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22
-- SPDX-License-Identifier: Apache-2.0
3-
{-# LANGUAGE NamedFieldPuns #-}
4-
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE LambdaCase #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE ScopedTypeVariables #-}
57
module Main(main) where
68

79
import Control.Arrow ((&&&))
@@ -10,13 +12,14 @@ import Data.Function ((&))
1012
import Data.Text (Text)
1113
import qualified Development.IDE.Main as GhcideMain
1214
import Development.IDE.Types.Logger (Doc, Priority (Error, Info),
15+
Recorder,
1316
WithPriority (WithPriority, priority),
1417
cfilter, cmapWithPrio,
1518
defaultLayoutOptions,
16-
layoutPretty,
19+
layoutPretty, logWith,
1720
makeDefaultStderrRecorder,
1821
payload, renderStrict,
19-
withDefaultRecorder)
22+
withFileRecorder)
2023
import qualified Development.IDE.Types.Logger as Logger
2124
import qualified HlsPlugins as Plugins
2225
import Ide.Arguments (Arguments (..),
@@ -30,7 +33,11 @@ import Ide.Types (PluginDescriptor (pluginNotificat
3033
mkPluginNotificationHandler)
3134
import Language.LSP.Server as LSP
3235
import Language.LSP.Types as LSP
33-
import Prettyprinter (Pretty (pretty), vsep)
36+
import Prettyprinter (Pretty (pretty), vcat, vsep)
37+
import Control.Exception (displayException)
38+
import Data.Bifunctor (first)
39+
import Data.Functor ((<&>))
40+
import Data.Maybe (catMaybes)
3441

3542
data Log
3643
= LogIdeMain IdeMain.Log
@@ -43,13 +50,27 @@ instance Pretty Log where
4350

4451
main :: IO ()
4552
main = do
53+
stderrRecorder <- makeDefaultStderrRecorder Nothing
4654
-- plugin cli commands use stderr logger for now unless we change the args
4755
-- parser to get logging arguments first or do more complicated things
48-
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing
56+
let pluginCliRecorder = cmapWithPrio pretty stderrRecorder
4957
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder))
5058

51-
(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
52-
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
59+
-- Recorder that logs to the LSP client with logMessage
60+
(lspLogRecorder, cb1) <-
61+
Logger.withBacklog Logger.lspClientLogRecorder
62+
<&> first (cmapWithPrio renderDoc)
63+
-- Recorder that logs to the LSP client with showMessage
64+
(lspMessageRecorder, cb2) <-
65+
Logger.withBacklog Logger.lspClientMessageRecorder
66+
<&> first (cmapWithPrio renderDoc)
67+
-- Recorder that logs Error severity logs to the client with showMessage and some extra text
68+
let lspErrorMessageRecorder = lspMessageRecorder
69+
& cfilter (\WithPriority{ priority } -> priority >= Error)
70+
& cmapWithPrio (\msg -> vsep
71+
["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
72+
, msg
73+
])
5374
-- This plugin just installs a handler for the `initialized` notification, which then
5475
-- picks up the LSP environment and feeds it to our recorders
5576
let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")
@@ -58,28 +79,35 @@ main = do
5879
liftIO $ (cb1 <> cb2) env
5980
}
6081

61-
let (argsTesting, minPriority, logFilePath) =
82+
let (minPriority, logFilePath, logStderr, logClient) =
6283
case args of
63-
Ghcide GhcideArguments{ argsTesting, argsLogLevel, argsLogFile} ->
64-
(argsTesting, argsLogLevel, argsLogFile)
65-
_ -> (False, Info, Nothing)
84+
Ghcide GhcideArguments{ argsLogLevel, argsLogFile, argsLogStderr, argsLogClient} ->
85+
(argsLogLevel, argsLogFile, argsLogStderr, argsLogClient)
86+
_ -> (Info, Nothing, True, False)
6687

67-
withDefaultRecorder logFilePath Nothing $ \textWithPriorityRecorder -> do
88+
-- Adapter for withFileRecorder to handle the case where we don't want to log to a file
89+
let withLogFileRecorder action = case logFilePath of
90+
Just p -> withFileRecorder p Nothing $ \case
91+
Left e -> do
92+
let exceptionMessage = pretty $ displayException e
93+
let message = vcat [exceptionMessage, "Couldn't open log file; not logging to it."]
94+
logWith stderrRecorder Error message
95+
action Nothing
96+
Right r -> action (Just r)
97+
Nothing -> action Nothing
98+
99+
withLogFileRecorder $ \logFileRecorder -> do
68100
let
69-
recorder = cmapWithPrio (pretty &&& id) $ mconcat
70-
[textWithPriorityRecorder
71-
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
72-
& cmapWithPrio fst
73-
, lspMessageRecorder
74-
& cfilter (\WithPriority{ priority } -> priority >= Error)
75-
& cmapWithPrio (renderDoc . fst)
76-
, lspLogRecorder
77-
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
78-
& cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions . fst)
79-
-- do not log heap stats to the LSP log as they interfere with the
80-
-- ability of lsp-test to detect a stuck server in tests and benchmarks
81-
& if argsTesting then cfilter (not . heapStats . snd . payload) else id
82-
]
101+
lfr = logFileRecorder
102+
ser = if logStderr then Just stderrRecorder else Nothing
103+
lemr = Just lspErrorMessageRecorder
104+
llr = if logClient then Just lspLogRecorder else Nothing
105+
recorder :: Recorder (WithPriority Log) =
106+
[lfr, ser, lemr, llr]
107+
& catMaybes
108+
& mconcat
109+
& cmapWithPrio pretty
110+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
83111
plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder)
84112

85113
defaultMain
@@ -88,14 +116,7 @@ main = do
88116
(plugins <> pluginDescToIdePlugins [lspRecorderPlugin])
89117

90118
renderDoc :: Doc a -> Text
91-
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep
92-
["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
93-
,d
94-
]
119+
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions d
95120

96121
issueTrackerUrl :: Doc a
97122
issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues"
98-
99-
heapStats :: Log -> Bool
100-
heapStats (LogIdeMain (IdeMain.LogIDEMain (GhcideMain.LogHeapStats _))) = True
101-
heapStats _ = False

‎ghcide/src/Development/IDE/Types/Logger.hs

Lines changed: 11 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ module Development.IDE.Types.Logger
1616
, cmap
1717
, cmapIO
1818
, cfilter
19-
, withDefaultRecorder
19+
, withFileRecorder
2020
, makeDefaultStderrRecorder
2121
, makeDefaultHandleRecorder
2222
, LoggingColumn(..)
@@ -156,35 +156,22 @@ makeDefaultStderrRecorder columns = do
156156
lock <- liftIO newLock
157157
makeDefaultHandleRecorder columns lock stderr
158158

159-
-- | If no path given then use stderr, otherwise use file.
160-
withDefaultRecorder
159+
withFileRecorder
161160
:: MonadUnliftIO m
162-
=> Maybe FilePath
163-
-- ^ Log file path. `Nothing` uses stderr
161+
=> FilePath
162+
-- ^ Log file path.
164163
-> Maybe [LoggingColumn]
165164
-- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
166-
-> (Recorder (WithPriority (Doc d)) -> m a)
167-
-- ^ action given a recorder
165+
-> (Either IOException (Recorder (WithPriority (Doc d))) -> m a)
166+
-- ^ action given a recorder, or the exception if we failed to open the file
168167
-> m a
169-
withDefaultRecorder path columns action = do
168+
withFileRecorder path columns action = do
170169
lock <- liftIO newLock
171170
let makeHandleRecorder = makeDefaultHandleRecorder columns lock
172-
case path of
173-
Nothing -> do
174-
recorder <- makeHandleRecorder stderr
175-
let message = "No log file specified; using stderr."
176-
logWith recorder Info message
177-
action recorder
178-
Just path -> do
179-
fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)
180-
case fileHandle of
181-
Left e -> do
182-
recorder <- makeHandleRecorder stderr
183-
let exceptionMessage = pretty $ displayException e
184-
let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."]
185-
logWith recorder Warning message
186-
action recorder
187-
Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle)
171+
fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)
172+
case fileHandle of
173+
Left e -> action $ Left e
174+
Right fileHandle -> finally ((Right <$> makeHandleRecorder fileHandle) >>= action) (liftIO $ hClose fileHandle)
188175

189176
makeDefaultHandleRecorder
190177
:: MonadIO m

‎src/Ide/Arguments.hs

Lines changed: 40 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -40,14 +40,16 @@ data Arguments
4040
| PrintLibDir
4141

4242
data GhcideArguments = GhcideArguments
43-
{argsCommand :: Command
44-
,argsCwd :: Maybe FilePath
45-
,argsShakeProfiling :: Maybe FilePath
46-
,argsTesting :: Bool
47-
,argsExamplePlugin :: Bool
43+
{ argsCommand :: Command
44+
, argsCwd :: Maybe FilePath
45+
, argsShakeProfiling :: Maybe FilePath
46+
, argsTesting :: Bool
47+
, argsExamplePlugin :: Bool
4848
, argsLogLevel :: Priority
4949
, argsLogFile :: Maybe String
5050
-- ^ the minimum log level to show
51+
, argsLogStderr :: Bool
52+
, argsLogClient :: Bool
5153
, argsThreads :: Int
5254
, argsProjectGhcVersion :: Bool
5355
} deriving Show
@@ -138,12 +140,40 @@ arguments plugins = GhcideArguments
138140
<> help "Sets the log level to Debug, alias for '--log-level Debug'"
139141
)
140142
)
141-
<*> optional (strOption
142-
(long "logfile"
143-
<> short 'l'
143+
-- This option is a little inconsistent with the other log options, since
144+
-- it's not a boolean and there is no way to turn it off. That's okay
145+
-- since the default is off.
146+
<*> (optional (strOption
147+
( long "log-file"
144148
<> metavar "LOGFILE"
145-
<> help "File to log to, defaults to stdout"
146-
))
149+
<> help "Send logs to a file"
150+
)) <|> (optional (strOption
151+
( long "logfile"
152+
<> metavar "LOGFILE"
153+
<> help "Send logs to a file"
154+
-- deprecated alias so users don't need to update their CLI calls
155+
-- immediately
156+
<> internal
157+
)))
158+
)
159+
-- Boolean option so we can toggle the default in a consistent way
160+
<*> option auto
161+
( long "log-stderr"
162+
<> help "Send logs to stderr"
163+
<> metavar "BOOL"
164+
<> value True
165+
<> showDefault
166+
)
167+
-- Boolean option so we can toggle the default in a consistent way
168+
<*> option auto
169+
( long "log-client"
170+
<> help "Send logs to the client using the window/logMessage LSP method"
171+
<> metavar "BOOL"
172+
-- This is off by default, since some clients will show duplicate logs
173+
-- if we log both to stderr and the client
174+
<> value False
175+
<> showDefault
176+
)
147177
<*> option auto
148178
(short 'j'
149179
<> help "Number of threads (0: automatic)"

0 commit comments

Comments
 (0)