Skip to content

Commit 5b61944

Browse files
michaelpjmichaelpj
committed
Refactor LSP logger to pass environment via an MVar
Also adds a logger that forwards on messages via `window/logMessage`.
1 parent e29f61f commit 5b61944

File tree

9 files changed

+150
-116
lines changed

9 files changed

+150
-116
lines changed

‎exe/Main.hs

Lines changed: 15 additions & 5 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.Concurrent (newEmptyMVar)
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,
@@ -36,7 +37,10 @@ main = do
3637
-- parser to get logging arguments first or do more complicated things
3738
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info
3839
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False)
39-
(lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder
40+
41+
lspEnvVar <- newEmptyMVar
42+
lspLogRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientLogRecorder
43+
lspMessageRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientMessageRecorder
4044

4145
let (minPriority, logFilePath, includeExamplePlugins) =
4246
case args of
@@ -50,13 +54,19 @@ main = do
5054
recorder = cmapWithPrio pretty $ mconcat
5155
[textWithPriorityRecorder
5256
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
53-
, lspRecorder
57+
, lspMessageRecorder
5458
& cfilter (\WithPriority{ priority } -> priority >= Error)
5559
& cmapWithPrio renderDoc
60+
, lspLogRecorder
61+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
62+
& cmapWithPrio renderDoc
5663
]
57-
plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins
5864

59-
defaultMain (cmapWithPrio LogIdeMain recorder) args (pluginDescToIdePlugins [lspRecorderPlugin] <> plugins)
65+
defaultMain
66+
(cmapWithPrio LogIdeMain recorder)
67+
(Just lspEnvVar)
68+
args
69+
(Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)
6070

6171
renderDoc :: Doc a -> Text
6272
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep

‎ghcide/exe/Main.hs

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Main(main) where
77

88
import Arguments (Arguments (..),
99
getArguments)
10+
import Control.Concurrent (newEmptyMVar)
1011
import Control.Monad.Extra (unless)
1112
import Data.Default (def)
1213
import Data.Function ((&))
@@ -27,7 +28,7 @@ import Development.IDE.Types.Logger (Logger (Logger),
2728
Recorder (Recorder),
2829
WithPriority (WithPriority, priority),
2930
cfilter, cmapWithPrio,
30-
makeDefaultStderrRecorder, layoutPretty, renderStrict, payload, defaultLayoutOptions)
31+
makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions)
3132
import qualified Development.IDE.Types.Logger as Logger
3233
import Development.IDE.Types.Options
3334
import GHC.Stack (emptyCallStack)
@@ -39,8 +40,6 @@ import System.Environment (getExecutablePath)
3940
import System.Exit (exitSuccess)
4041
import System.IO (hPutStrLn, stderr)
4142
import System.Info (compilerVersion)
42-
import Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder)
43-
import Control.Lens (Contravariant(contramap))
4443

4544
data Log
4645
= LogIDEMain IDEMain.Log
@@ -88,13 +87,16 @@ main = withTelemetryLogger $ \telemetryLogger -> do
8887

8988
docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
9089

91-
(lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder
90+
lspEnvVar <- newEmptyMVar
91+
lspLogRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientLogRecorder
92+
lspMessageRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientMessageRecorder
9293

9394
let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
9495
(docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>
95-
(lspRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
96-
& cfilter (\WithPriority{ priority } -> priority >= Error)
97-
)
96+
(lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
97+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>
98+
(lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
99+
& cfilter (\WithPriority{ priority } -> priority >= Error))
98100

99101
-- exists so old-style logging works. intended to be phased out
100102
let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))
@@ -107,11 +109,10 @@ main = withTelemetryLogger $ \telemetryLogger -> do
107109
then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger
108110
else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger
109111

110-
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
112+
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (Just lspEnvVar) arguments
111113
{ IDEMain.argsProjectRoot = Just argsCwd
112114
, IDEMain.argCommand = argsCommand
113115
, IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger
114-
, IDEMain.argsHlsPlugins = pluginDescToIdePlugins [lspRecorderPlugin] <> IDEMain.argsHlsPlugins arguments
115116

116117
, IDEMain.argsRules = do
117118
-- 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/Main.hs

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Development.IDE.Main
1111
,testing
1212
,Log(..)
1313
) where
14+
import Control.Concurrent (MVar, putMVar)
1415
import Control.Concurrent.Extra (withNumCapabilities)
1516
import Control.Concurrent.STM.Stats (atomically,
1617
dumpSTMStats)
@@ -20,7 +21,7 @@ import Control.Monad.Extra (concatMapM, unless,
2021
when)
2122
import qualified Data.Aeson.Encode.Pretty as A
2223
import Data.Default (Default (def))
23-
import Data.Foldable (traverse_)
24+
import Data.Foldable (traverse_, for_)
2425
import qualified Data.HashMap.Strict as HashMap
2526
import Data.Hashable (hashed)
2627
import Data.List.Extra (intercalate, isPrefixOf,
@@ -233,7 +234,6 @@ data Arguments = Arguments
233234
, argsThreads :: Maybe Natural
234235
}
235236

236-
237237
defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments
238238
defaultArguments recorder logger = Arguments
239239
{ argsProjectRoot = Nothing
@@ -289,9 +289,14 @@ testing recorder logger =
289289
, argsIdeOptions = ideOptions
290290
}
291291

292-
293-
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
294-
defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
292+
defaultMain
293+
:: Recorder (WithPriority Log)
294+
-> Maybe (MVar (LSP.LanguageContextEnv Config))
295+
-- ^ Variable to be filled with the LSP environment, useful for tools that need this outside
296+
-- the scope of runLanguageServer
297+
-> Arguments
298+
-> IO ()
299+
defaultMain recorder lspEnvVar Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
295300
where
296301
log :: Priority -> Log -> IO ()
297302
log = logWith recorder
@@ -329,6 +334,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
329334
t <- t
330335
log Info $ LogLspStartDuration t
331336

337+
for_ lspEnvVar $ \var -> putMVar var env
338+
332339
dir <- maybe IO.getCurrentDirectory return rootPath
333340

334341
-- We want to set the global DynFlags right now, so that we can use

‎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: 92 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -21,38 +21,51 @@ 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 (MVar, myThreadId, tryReadMVar)
32+
import Control.Concurrent.Extra (Lock, newLock, withLock)
33+
import Control.Concurrent.STM (atomically, newTQueueIO,
34+
writeTQueue)
35+
import Control.Concurrent.STM.TQueue (flushTQueue)
36+
import Control.Exception (IOException)
37+
import Control.Monad (forM_, when, (>=>))
38+
import Control.Monad.IO.Class (MonadIO (liftIO))
39+
import Data.Foldable (for_)
40+
import Data.Functor.Contravariant (Contravariant (contramap))
41+
import Data.Maybe (fromMaybe)
42+
import Data.Text (Text)
43+
import qualified Data.Text as T
44+
import qualified Data.Text as Text
45+
import qualified Data.Text.IO as Text
46+
import Data.Time (defaultTimeLocale, formatTime,
47+
getCurrentTime)
48+
import GHC.Stack (CallStack, HasCallStack,
49+
SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),
50+
callStack, getCallStack,
51+
withFrozenCallStack)
52+
import Language.LSP.Server
53+
import qualified Language.LSP.Server as LSP
54+
import Language.LSP.Types (LogMessageParams (..),
55+
MessageType (..),
56+
SMethod (SWindowLogMessage, SWindowShowMessage),
57+
ShowMessageParams (..))
58+
import Prettyprinter as PrettyPrinterModule
59+
import Prettyprinter.Render.Text (renderStrict)
60+
import System.IO (Handle, IOMode (AppendMode),
61+
hClose, hFlush, hSetEncoding,
62+
openFile, stderr, utf8)
63+
import qualified System.Log.Formatter as HSL
64+
import qualified System.Log.Handler as HSL
65+
import qualified System.Log.Handler.Simple as HSL
66+
import qualified System.Log.Logger as HsLogger
67+
import UnliftIO (MonadUnliftIO, displayException,
68+
finally, try)
5669

5770
data Priority
5871
-- Don't change the ordering of this type or you will mess up the Ord
@@ -204,10 +217,10 @@ makeDefaultHandleRecorder columns minPriority lock handle = do
204217

205218
priorityToHsLoggerPriority :: Priority -> HsLogger.Priority
206219
priorityToHsLoggerPriority = \case
207-
Debug -> HsLogger.DEBUG
208-
Info -> HsLogger.INFO
209-
Warning -> HsLogger.WARNING
210-
Error -> HsLogger.ERROR
220+
Debug -> HsLogger.DEBUG
221+
Info -> HsLogger.INFO
222+
Warning -> HsLogger.WARNING
223+
Error -> HsLogger.ERROR
211224

212225
-- | The purpose of setting up `hslogger` at all is that `hie-bios` uses
213226
-- `hslogger` to output compilation logs. The easiest way to merge these logs
@@ -290,3 +303,50 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d
290303
pure (threadIdToText threadId)
291304
PriorityColumn -> pure (priorityToText priority)
292305
DataColumn -> pure payload
306+
307+
-- | Given a 'Recorder' that requires an argument, and an 'MVar' that
308+
-- will eventually be filled with that argument, produces a 'Recorder'
309+
-- that queues up messages until the argument is available, at which
310+
-- point it sends the backlog.
311+
withBacklog :: MVar v -> (v -> Recorder a) -> IO (Recorder a)
312+
withBacklog argVar recFun = do
313+
backlog <- newTQueueIO
314+
pure $ Recorder $ \it -> do
315+
marg <- liftIO $ tryReadMVar argVar
316+
case marg of
317+
Nothing -> liftIO $ atomically $ writeTQueue backlog it
318+
Just arg -> do
319+
let recorder = recFun arg
320+
toRecord <- liftIO $ atomically $ flushTQueue backlog
321+
for_ toRecord (logger_ recorder)
322+
logger_ recorder it
323+
324+
-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.
325+
lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
326+
lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->
327+
LSP.runLspT env $
328+
LSP.sendNotification
329+
SWindowShowMessage
330+
ShowMessageParams
331+
{ _xtype = priorityToLsp priority,
332+
_message = payload
333+
}
334+
335+
-- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.
336+
lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
337+
lspClientLogRecorder env = Recorder $ \WithPriority {..} ->
338+
LSP.runLspT env $
339+
LSP.sendNotification
340+
SWindowLogMessage
341+
LogMessageParams
342+
{ _xtype = priorityToLsp priority,
343+
_message = payload
344+
}
345+
346+
priorityToLsp :: Priority -> MessageType
347+
priorityToLsp =
348+
\case
349+
Debug -> MtLog
350+
Info -> MtInfo
351+
Warning -> MtWarning
352+
Error -> MtError

‎ghcide/test/exe/Main.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6407,7 +6407,7 @@ testIde recorder arguments session = do
64076407
(hInRead, hInWrite) <- createPipe
64086408
(hOutRead, hOutWrite) <- createPipe
64096409
let projDir = "."
6410-
let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
6410+
let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) Nothing arguments
64116411
{ IDE.argsHandleIn = pure hInRead
64126412
, IDE.argsHandleOut = pure hOutWrite
64136413
}

‎hls-test-utils/src/Test/Hls.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -219,6 +219,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre
219219
async $
220220
Ghcide.defaultMain
221221
(cmapWithPrio LogIDEMain recorder)
222+
Nothing
222223
arguments
223224
{ argsHandleIn = pure inR
224225
, argsHandleOut = pure outW

0 commit comments

Comments
 (0)