Skip to content

Commit 53604eb

Browse files
michaelpjmichaelpj
authored
Add arguments to direct logs to various locations (#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
1 parent e3beaa0 commit 53604eb

File tree

4 files changed

+118
-109
lines changed

4 files changed

+118
-109
lines changed

Diff for: ‎exe/Main.hs

+56-38
Original file line numberDiff line numberDiff line change
@@ -1,22 +1,26 @@
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

7-
import Control.Arrow ((&&&))
9+
import Control.Exception (displayException)
810
import Control.Monad.IO.Class (liftIO)
11+
import Data.Bifunctor (first)
912
import Data.Function ((&))
13+
import Data.Functor ((<&>))
14+
import Data.Maybe (catMaybes)
1015
import Data.Text (Text)
11-
import qualified Development.IDE.Main as GhcideMain
1216
import Development.IDE.Types.Logger (Doc, Priority (Error, Info),
17+
Recorder,
1318
WithPriority (WithPriority, priority),
1419
cfilter, cmapWithPrio,
1520
defaultLayoutOptions,
16-
layoutPretty,
21+
layoutPretty, logWith,
1722
makeDefaultStderrRecorder,
18-
payload, renderStrict,
19-
withDefaultRecorder)
23+
renderStrict, withFileRecorder)
2024
import qualified Development.IDE.Types.Logger as Logger
2125
import qualified HlsPlugins as Plugins
2226
import Ide.Arguments (Arguments (..),
@@ -30,7 +34,7 @@ import Ide.Types (PluginDescriptor (pluginNotifica
3034
mkPluginNotificationHandler)
3135
import Language.LSP.Protocol.Message as LSP
3236
import Language.LSP.Server as LSP
33-
import Prettyprinter (Pretty (pretty), vsep)
37+
import Prettyprinter (Pretty (pretty), vcat, vsep)
3438

3539
data Log
3640
= LogIdeMain IdeMain.Log
@@ -43,13 +47,27 @@ instance Pretty Log where
4347

4448
main :: IO ()
4549
main = do
50+
stderrRecorder <- makeDefaultStderrRecorder Nothing
4651
-- plugin cli commands use stderr logger for now unless we change the args
4752
-- parser to get logging arguments first or do more complicated things
48-
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing
53+
let pluginCliRecorder = cmapWithPrio pretty stderrRecorder
4954
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder))
5055

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

61-
let (argsTesting, minPriority, logFilePath) =
79+
let (minPriority, logFilePath, logStderr, logClient) =
6280
case args of
63-
Ghcide GhcideArguments{ argsTesting, argsLogLevel, argsLogFile} ->
64-
(argsTesting, argsLogLevel, argsLogFile)
65-
_ -> (False, Info, Nothing)
81+
Ghcide GhcideArguments{ argsLogLevel, argsLogFile, argsLogStderr, argsLogClient} ->
82+
(argsLogLevel, argsLogFile, argsLogStderr, argsLogClient)
83+
_ -> (Info, Nothing, True, False)
6684

67-
withDefaultRecorder logFilePath Nothing $ \textWithPriorityRecorder -> do
85+
-- Adapter for withFileRecorder to handle the case where we don't want to log to a file
86+
let withLogFileRecorder action = case logFilePath of
87+
Just p -> withFileRecorder p Nothing $ \case
88+
Left e -> do
89+
let exceptionMessage = pretty $ displayException e
90+
let message = vcat [exceptionMessage, "Couldn't open log file; not logging to it."]
91+
logWith stderrRecorder Error message
92+
action Nothing
93+
Right r -> action (Just r)
94+
Nothing -> action Nothing
95+
96+
withLogFileRecorder $ \logFileRecorder -> do
6897
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-
]
98+
lfr = logFileRecorder
99+
ser = if logStderr then Just stderrRecorder else Nothing
100+
lemr = Just lspErrorMessageRecorder
101+
llr = if logClient then Just lspLogRecorder else Nothing
102+
recorder :: Recorder (WithPriority Log) =
103+
[lfr, ser, lemr, llr]
104+
& catMaybes
105+
& mconcat
106+
& cmapWithPrio pretty
107+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
83108
plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder)
84109

85110
defaultMain
@@ -88,14 +113,7 @@ main = do
88113
(plugins <> pluginDescToIdePlugins [lspRecorderPlugin])
89114

90115
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-
]
116+
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions d
95117

96118
issueTrackerUrl :: Doc a
97119
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

Diff for: ‎ghcide/src/Development/IDE/Types/Logger.hs

+11-24
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(..)
@@ -157,35 +157,22 @@ makeDefaultStderrRecorder columns = do
157157
lock <- liftIO newLock
158158
makeDefaultHandleRecorder columns lock stderr
159159

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

190177
makeDefaultHandleRecorder
191178
:: MonadIO m

Diff for: ‎src/Ide/Arguments.hs

+40-10
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)"

Diff for: ‎test/functional/Config.hs

+11-37
Original file line numberDiff line numberDiff line change
@@ -6,59 +6,33 @@
66
module Config (tests) where
77

88
import Control.DeepSeq
9-
import Control.Lens hiding (List, (.=))
109
import Control.Monad
1110
import Data.Aeson
1211
import Data.Hashable
13-
import qualified Data.HashMap.Strict as HM
14-
import qualified Data.Map as Map
15-
import Data.Proxy
16-
import qualified Data.Text as T
17-
import Data.Typeable (Typeable)
18-
import Development.IDE (RuleResult, action, define,
19-
getFilesOfInterestUntracked,
20-
getPluginConfigAction,
21-
ideErrorText, uses_)
22-
import Development.IDE.Test (expectDiagnostics)
12+
import qualified Data.HashMap.Strict as HM
13+
import qualified Data.Map as Map
14+
import Data.Typeable (Typeable)
15+
import Development.IDE (RuleResult, action, define,
16+
getFilesOfInterestUntracked,
17+
getPluginConfigAction, ideErrorText,
18+
uses_)
19+
import Development.IDE.Test (expectDiagnostics)
2320
import GHC.Generics
2421
import Ide.Plugin.Config
2522
import Ide.Types
26-
import qualified Language.LSP.Protocol.Lens as L
27-
import Language.LSP.Test as Test
28-
import System.FilePath ((</>))
23+
import Language.LSP.Test as Test
24+
import System.FilePath ((</>))
2925
import Test.Hls
30-
import Test.Hls.Command
3126

3227
{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
3328

3429
tests :: TestTree
3530
tests = testGroup "plugin config" [
3631
-- Note: there are more comprehensive tests over config in hls-hlint-plugin
3732
-- TODO: Add generic tests over some example plugin
38-
configParsingTests, genericConfigTests
33+
genericConfigTests
3934
]
4035

41-
configParsingTests :: TestTree
42-
configParsingTests = testGroup "config parsing"
43-
[ testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do
44-
let config = object []
45-
sendConfigurationChanged (toJSON config)
46-
47-
-- Send custom request so server returns a response to prevent blocking
48-
void $ sendNotification (SMethod_CustomMethod (Proxy @"non-existent-method")) Null
49-
50-
logNot <- skipManyTill Test.anyMessage (message SMethod_WindowLogMessage)
51-
52-
liftIO $ (logNot ^. L.params . L.type_) > MessageType_Error
53-
|| "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message)
54-
@? "Server sends logMessage with MessageType = Error"
55-
]
56-
57-
where
58-
runConfigSession :: FilePath -> Session a -> IO a
59-
runConfigSession subdir =
60-
failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata" </> subdir)
61-
6236
genericConfigTests :: TestTree
6337
genericConfigTests = testGroup "generic plugin config"
6438
[

0 commit comments

Comments
 (0)