Skip to content

Commit 82a3cd5

Browse files
michaelpjpepeiborra
michaelpj
and
pepeiborra
authored
Refactor LSP logger and log via window/logMessage also (#2758)
* Refactor LSP logger and log via `window/logMessage` * Skip logging notifications in tests Co-authored-by: Pepe Iborra <[email protected]>
1 parent 9f034f2 commit 82a3cd5

File tree

6 files changed

+149
-107
lines changed

6 files changed

+149
-107
lines changed

‎exe/Main.hs‎

Lines changed: 25 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -4,9 +4,10 @@
44
{-# LANGUAGE OverloadedStrings #-}
55
module Main(main) where
66

7+
import Control.Monad.IO.Class (liftIO)
78
import Data.Function ((&))
89
import Data.Text (Text)
9-
import Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder)
10+
import qualified Development.IDE.Types.Logger as Logger
1011
import Development.IDE.Types.Logger (Priority (Debug, Info, Error),
1112
WithPriority (WithPriority, priority),
1213
cfilter, cmapWithPrio,
@@ -17,7 +18,10 @@ import Ide.Arguments (Arguments (..),
1718
getArguments)
1819
import Ide.Main (defaultMain)
1920
import qualified Ide.Main as IdeMain
20-
import Ide.PluginUtils (pluginDescToIdePlugins)
21+
import Ide.PluginUtils (pluginDescToIdePlugins)
22+
import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler)
23+
import Language.LSP.Server as LSP
24+
import Language.LSP.Types as LSP
2125
import qualified Plugins
2226
import Prettyprinter (Pretty (pretty), vsep)
2327

@@ -36,7 +40,16 @@ main = do
3640
-- parser to get logging arguments first or do more complicated things
3741
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info
3842
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False)
39-
(lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder
43+
44+
(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
45+
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
46+
-- This plugin just installs a handler for the `initialized` notification, which then
47+
-- picks up the LSP environment and feeds it to our recorders
48+
let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")
49+
{ pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ -> do
50+
env <- LSP.getLspEnv
51+
liftIO $ (cb1 <> cb2) env
52+
}
4053

4154
let (minPriority, logFilePath, includeExamplePlugins) =
4255
case args of
@@ -50,13 +63,19 @@ main = do
5063
recorder = cmapWithPrio pretty $ mconcat
5164
[textWithPriorityRecorder
5265
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
53-
, lspRecorder
66+
, lspMessageRecorder
5467
& cfilter (\WithPriority{ priority } -> priority >= Error)
5568
& cmapWithPrio renderDoc
69+
, lspLogRecorder
70+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
71+
& cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
5672
]
57-
plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins
73+
plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)
5874

59-
defaultMain (cmapWithPrio LogIdeMain recorder) args (pluginDescToIdePlugins [lspRecorderPlugin] <> plugins)
75+
defaultMain
76+
(cmapWithPrio LogIdeMain recorder)
77+
args
78+
(plugins <> pluginDescToIdePlugins [lspRecorderPlugin])
6079

6180
renderDoc :: Doc a -> Text
6281
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep

‎ghcide/exe/Main.hs‎

Lines changed: 19 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Main(main) where
88
import Arguments (Arguments (..),
99
getArguments)
1010
import Control.Monad.Extra (unless)
11+
import Control.Monad.IO.Class (liftIO)
1112
import Data.Default (def)
1213
import Data.Function ((&))
1314
import Data.Version (showVersion)
@@ -26,20 +27,21 @@ import Development.IDE.Types.Logger (Logger (Logger),
2627
Recorder (Recorder),
2728
WithPriority (WithPriority, priority),
2829
cfilter, cmapWithPrio,
29-
makeDefaultStderrRecorder, layoutPretty, renderStrict, payload, defaultLayoutOptions)
30+
makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions)
3031
import qualified Development.IDE.Types.Logger as Logger
3132
import Development.IDE.Types.Options
3233
import GHC.Stack (emptyCallStack)
34+
import Language.LSP.Server as LSP
35+
import Language.LSP.Types as LSP
3336
import Ide.Plugin.Config (Config (checkParents, checkProject))
3437
import Ide.PluginUtils (pluginDescToIdePlugins)
38+
import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler)
3539
import Paths_ghcide (version)
3640
import qualified System.Directory.Extra as IO
3741
import System.Environment (getExecutablePath)
3842
import System.Exit (exitSuccess)
3943
import System.IO (hPutStrLn, stderr)
4044
import System.Info (compilerVersion)
41-
import Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder)
42-
import Control.Lens (Contravariant(contramap))
4345

4446
data Log
4547
= LogIDEMain IDEMain.Log
@@ -87,13 +89,22 @@ main = withTelemetryLogger $ \telemetryLogger -> do
8789

8890
docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
8991

90-
(lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder
92+
(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
93+
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
94+
-- This plugin just installs a handler for the `initialized` notification, which then
95+
-- picks up the LSP environment and feeds it to our recorders
96+
let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")
97+
{ pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ -> do
98+
env <- LSP.getLspEnv
99+
liftIO $ (cb1 <> cb2) env
100+
}
91101

92102
let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
93103
(docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>
94-
(lspRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
95-
& cfilter (\WithPriority{ priority } -> priority >= Error)
96-
)
104+
(lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
105+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>
106+
(lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
107+
& cfilter (\WithPriority{ priority } -> priority >= Error))
97108

98109
-- exists so old-style logging works. intended to be phased out
99110
let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))
@@ -110,7 +121,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do
110121
{ IDEMain.argsProjectRoot = Just argsCwd
111122
, IDEMain.argCommand = argsCommand
112123
, IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger
113-
, IDEMain.argsHlsPlugins = pluginDescToIdePlugins [lspRecorderPlugin] <> IDEMain.argsHlsPlugins arguments
124+
, IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]
114125

115126
, IDEMain.argsRules = do
116127
-- install the main and ghcide-plugin rules

‎ghcide/ghcide.cabal‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -202,7 +202,6 @@ library
202202
Development.IDE.Plugin.Completions.Types
203203
Development.IDE.Plugin.CodeAction
204204
Development.IDE.Plugin.CodeAction.ExactPrint
205-
Development.IDE.Plugin.LSPWindowShowMessageRecorder
206205
Development.IDE.Plugin.HLS
207206
Development.IDE.Plugin.HLS.GhcIde
208207
Development.IDE.Plugin.Test

‎ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs‎

Lines changed: 0 additions & 57 deletions
This file was deleted.

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

Lines changed: 102 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -21,38 +21,50 @@ module Development.IDE.Types.Logger
2121
, priorityToHsLoggerPriority
2222
, LoggingColumn(..)
2323
, cmapWithPrio
24+
, withBacklog
25+
, lspClientMessageRecorder
26+
, lspClientLogRecorder
2427
, module PrettyPrinterModule
2528
, renderStrict
2629
) where
2730

28-
import Control.Concurrent (myThreadId)
29-
import Control.Concurrent.Extra (Lock, newLock, withLock)
30-
import Control.Exception (IOException)
31-
import Control.Monad (forM_, when, (>=>))
32-
import Control.Monad.IO.Class (MonadIO (liftIO))
33-
import Data.Functor.Contravariant (Contravariant (contramap))
34-
import Data.Maybe (fromMaybe)
35-
import Data.Text (Text)
36-
import qualified Data.Text as T
37-
import qualified Data.Text as Text
38-
import qualified Data.Text.IO as Text
39-
import Data.Time (defaultTimeLocale, formatTime,
40-
getCurrentTime)
41-
import GHC.Stack (CallStack, HasCallStack,
42-
SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),
43-
callStack, getCallStack,
44-
withFrozenCallStack)
45-
import Prettyprinter as PrettyPrinterModule
46-
import Prettyprinter.Render.Text (renderStrict)
47-
import System.IO (Handle, IOMode (AppendMode),
48-
hClose, hFlush, hSetEncoding,
49-
openFile, stderr, utf8)
50-
import qualified System.Log.Formatter as HSL
51-
import qualified System.Log.Handler as HSL
52-
import qualified System.Log.Handler.Simple as HSL
53-
import qualified System.Log.Logger as HsLogger
54-
import UnliftIO (MonadUnliftIO, displayException,
55-
finally, try)
31+
import Control.Concurrent (myThreadId)
32+
import Control.Concurrent.Extra (Lock, newLock, withLock)
33+
import Control.Concurrent.STM (atomically,
34+
newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue)
35+
import Control.Exception (IOException)
36+
import Control.Monad (forM_, when, (>=>), unless)
37+
import Control.Monad.IO.Class (MonadIO (liftIO))
38+
import Data.Foldable (for_)
39+
import Data.Functor.Contravariant (Contravariant (contramap))
40+
import Data.Maybe (fromMaybe)
41+
import Data.Text (Text)
42+
import qualified Data.Text as T
43+
import qualified Data.Text as Text
44+
import qualified Data.Text.IO as Text
45+
import Data.Time (defaultTimeLocale, formatTime,
46+
getCurrentTime)
47+
import GHC.Stack (CallStack, HasCallStack,
48+
SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),
49+
callStack, getCallStack,
50+
withFrozenCallStack)
51+
import Language.LSP.Server
52+
import qualified Language.LSP.Server as LSP
53+
import Language.LSP.Types (LogMessageParams (..),
54+
MessageType (..),
55+
SMethod (SWindowLogMessage, SWindowShowMessage),
56+
ShowMessageParams (..))
57+
import Prettyprinter as PrettyPrinterModule
58+
import Prettyprinter.Render.Text (renderStrict)
59+
import System.IO (Handle, IOMode (AppendMode),
60+
hClose, hFlush, hSetEncoding,
61+
openFile, stderr, utf8)
62+
import qualified System.Log.Formatter as HSL
63+
import qualified System.Log.Handler as HSL
64+
import qualified System.Log.Handler.Simple as HSL
65+
import qualified System.Log.Logger as HsLogger
66+
import UnliftIO (MonadUnliftIO, displayException,
67+
finally, try)
5668

5769
data Priority
5870
-- Don't change the ordering of this type or you will mess up the Ord
@@ -204,10 +216,10 @@ makeDefaultHandleRecorder columns minPriority lock handle = do
204216

205217
priorityToHsLoggerPriority :: Priority -> HsLogger.Priority
206218
priorityToHsLoggerPriority = \case
207-
Debug -> HsLogger.DEBUG
208-
Info -> HsLogger.INFO
209-
Warning -> HsLogger.WARNING
210-
Error -> HsLogger.ERROR
219+
Debug -> HsLogger.DEBUG
220+
Info -> HsLogger.INFO
221+
Warning -> HsLogger.WARNING
222+
Error -> HsLogger.ERROR
211223

212224
-- | The purpose of setting up `hslogger` at all is that `hie-bios` uses
213225
-- `hslogger` to output compilation logs. The easiest way to merge these logs
@@ -290,3 +302,61 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d
290302
pure (threadIdToText threadId)
291303
PriorityColumn -> pure (priorityToText priority)
292304
DataColumn -> pure payload
305+
306+
-- | Given a 'Recorder' that requires an argument, produces a 'Recorder'
307+
-- that queues up messages until the argument is provided using the callback, at which
308+
-- point it sends the backlog and begins functioning normally.
309+
withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())
310+
withBacklog recFun = do
311+
-- Arbitrary backlog capacity
312+
backlog <- newTBQueueIO 100
313+
let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do
314+
-- If the queue is full just drop the message on the floor. This is most likely
315+
-- to happen if the callback is just never going to be called; in which case
316+
-- we want neither to build up an unbounded backlog in memory, nor block waiting
317+
-- for space!
318+
full <- isFullTBQueue backlog
319+
unless full $ writeTBQueue backlog it
320+
321+
-- The variable holding the recorder starts out holding the recorder that writes
322+
-- to the backlog.
323+
recVar <- newTVarIO backlogRecorder
324+
-- The callback atomically swaps out the recorder for the final one, and flushes
325+
-- the backlog to it.
326+
let cb arg = do
327+
let recorder = recFun arg
328+
toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog
329+
for_ toRecord (logger_ recorder)
330+
331+
-- The recorder we actually return looks in the variable and uses whatever is there.
332+
let varRecorder = Recorder $ \it -> do
333+
r <- liftIO $ readTVarIO recVar
334+
logger_ r it
335+
336+
pure (varRecorder, cb)
337+
338+
-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.
339+
lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
340+
lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->
341+
liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage
342+
ShowMessageParams
343+
{ _xtype = priorityToLsp priority,
344+
_message = payload
345+
}
346+
347+
-- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.
348+
lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
349+
lspClientLogRecorder env = Recorder $ \WithPriority {..} ->
350+
liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage
351+
LogMessageParams
352+
{ _xtype = priorityToLsp priority,
353+
_message = payload
354+
}
355+
356+
priorityToLsp :: Priority -> MessageType
357+
priorityToLsp =
358+
\case
359+
Debug -> MtLog
360+
Info -> MtInfo
361+
Warning -> MtWarning
362+
Error -> MtError

‎test/functional/FunctionalCodeAction.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ renameTests = testGroup "rename suggestions" [
4343
cars <- getAllCodeActions doc
4444
replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"]
4545
executeCommand replaceButStrLn
46-
_ <- anyRequest
46+
_ <- skipManyTill loggingNotification anyRequest
4747

4848
x:_ <- T.lines <$> documentContents doc
4949
liftIO $ x @?= "main = putStrLn \"hello\""
@@ -65,7 +65,7 @@ renameTests = testGroup "rename suggestions" [
6565
_ -> error $ "Unexpected arguments: " ++ show mbArgs
6666

6767
executeCommand cmd
68-
_ <- anyRequest
68+
_ <- skipManyTill loggingNotification anyRequest
6969

7070
x1:x2:_ <- T.lines <$> documentContents doc
7171
liftIO $
@@ -207,7 +207,7 @@ redundantImportTests = testGroup "redundant import code actions" [
207207
cas <- getAllCodeActions doc
208208
cmd <- liftIO $ inspectCommand cas ["redundant import"]
209209
executeCommand cmd
210-
_ <- anyRequest
210+
_ <- skipManyTill loggingNotification anyRequest
211211
contents <- documentContents doc
212212
liftIO $ T.lines contents @?=
213213
[ "{-# OPTIONS_GHC -Wunused-imports #-}"

0 commit comments

Comments
 (0)