Skip to content

Commit 57ac4a1

Browse files
michaelpjmichaelpj
committed
WIP lsp recorder
1 parent 0ba6a8e commit 57ac4a1

File tree

7 files changed

+96
-33
lines changed

7 files changed

+96
-33
lines changed

‎exe/Main.hs

+6-3
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import Development.IDE.Types.Logger (Priority (Debug, Info),
99
WithPriority (WithPriority, priority),
1010
cfilter, cmapWithPrio,
1111
makeDefaultStderrRecorder,
12-
withDefaultRecorder)
12+
withDefaultRecorder, makeDefaultClientRecorder)
1313
import Ide.Arguments (Arguments (..),
1414
GhcideArguments (..),
1515
getArguments)
@@ -44,7 +44,10 @@ main = do
4444
withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do
4545
let recorder =
4646
textWithPriorityRecorder
47-
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
47+
& cfilter (\m -> priority m >= minPriority)
4848
& cmapWithPrio pretty
49+
lspRecorder env = (makeDefaultClientRecorder env
50+
& cfilter (\m -> priority m >= minPriority)
51+
& cmapWithPrio pretty) <> recorder
4952

50-
defaultMain (cmapWithPrio LogIdeMain recorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)
53+
defaultMain (cmapWithPrio LogIdeMain recorder) (fmap (cmapWithPrio LogIdeMain) lspRecorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)

‎ghcide/exe/Main.hs

+14-3
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,12 @@ import System.Exit (exitSuccess)
4040
import System.IO (hPutStrLn, stderr)
4141
import System.Info (compilerVersion)
4242

43+
import Data.Text.Prettyprint.Doc
44+
45+
import qualified Colog.Core as L
46+
import qualified Language.LSP.Server as LSP
47+
import qualified Language.LSP.Logging as LSP
48+
4349
data Log
4450
= LogIDEMain IDEMain.Log
4551
| LogRules Rules.Log
@@ -88,20 +94,25 @@ main = withTelemetryLogger $ \telemetryLogger -> do
8894

8995
let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
9096
docWithPriorityRecorder
91-
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
97+
& cfilter (\m -> priority m >= minPriority)
9298

9399
-- exists so old-style logging works. intended to be phased out
94100
let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))
95101

96-
let recorder = docWithFilteredPriorityRecorder
102+
let
103+
recorder :: Recorder (WithPriority Log)
104+
recorder = docWithFilteredPriorityRecorder
97105
& cmapWithPrio pretty
106+
lspRecorder env = (Logger.makeDefaultClientRecorder env
107+
& cfilter (\m -> priority m >= minPriority)
108+
& cmapWithPrio pretty) <> recorder
98109

99110
let arguments =
100111
if argsTesting
101112
then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger
102113
else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger
103114

104-
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
115+
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (fmap (cmapWithPrio LogIDEMain) lspRecorder) arguments
105116
{ IDEMain.argsProjectRoot = Just argsCwd
106117
, IDEMain.argCommand = argsCommand
107118
, IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger

‎ghcide/ghcide.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -309,6 +309,7 @@ executable ghcide
309309
hiedb,
310310
aeson,
311311
base == 4.*,
312+
co-log-core,
312313
data-default,
313314
directory,
314315
extra,
@@ -325,6 +326,7 @@ executable ghcide
325326
ghcide,
326327
lens,
327328
optparse-applicative,
329+
prettyprinter,
328330
hls-graph,
329331
text,
330332
unordered-containers,

‎ghcide/src/Development/IDE/LSP/LanguageServer.hs

+13-18
Original file line numberDiff line numberDiff line change
@@ -84,7 +84,8 @@ newtype WithHieDbShield = WithHieDbShield WithHieDb
8484

8585
runLanguageServer
8686
:: forall config. (Show config)
87-
=> Recorder (WithPriority Log)
87+
=> Recorder (WithPriority Log) -- Recorder to use before startup
88+
-> (LSP.LanguageContextEnv config -> Recorder (WithPriority Log)) -- Recorder to use after the LSP env is ready
8889
-> LSP.Options
8990
-> Handle -- input
9091
-> Handle -- output
@@ -94,7 +95,7 @@ runLanguageServer
9495
-> LSP.Handlers (ServerM config)
9596
-> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
9697
-> IO ()
97-
runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do
98+
runLanguageServer recorder mkLspRecorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do
9899

99100
-- This MVar becomes full when the server thread exits or we receive exit message from client.
100101
-- LSP server will be canceled when it's full.
@@ -162,11 +163,13 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur
162163
L.Info -> Info
163164
L.Warning -> Warning
164165
L.Error -> Error
165-
let
166166
-- The IO-based logger the sever uses when starting up.
167167
ioLogger = L.LogAction $ \(L.WithSeverity l sev) -> logWith recorder (sevToPrio sev) (LogLsp l)
168-
-- The LPS-enabled logger the server uses once started. For now we just use the same logger.
169-
lspLogger = L.hoistLogAction liftIO ioLogger
168+
-- The LSP-enabled logger the server uses once started.
169+
lspLogger = L.LogAction $ \(L.WithSeverity l sev) -> do
170+
env <- LSP.getLspEnv
171+
let r = mkLspRecorder env
172+
liftIO $ logWith r (sevToPrio sev) (LogLsp l)
170173

171174
void $ untilMVar clientMsgVar $
172175
void $ LSP.runServerWithHandles
@@ -177,13 +180,14 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur
177180
serverDefinition
178181

179182
where
180-
log :: Logger.Priority -> Log -> IO ()
181-
log = logWith recorder
182-
183183
handleInit
184184
:: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
185185
-> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
186186
handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
187+
let lspRecorder = mkLspRecorder env
188+
log :: Logger.Priority -> Log -> IO ()
189+
log = logWith lspRecorder
190+
187191
traceWithSpan sp params
188192
let root = LSP.resRootPath env
189193
dir <- maybe getCurrentDirectory return root
@@ -203,20 +207,11 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur
203207

204208
let handleServerException (Left e) = do
205209
log Error $ LogReactorThreadException e
206-
sendErrorMessage e
207210
exitClientMsg
208211
handleServerException (Right _) = pure ()
209212

210-
sendErrorMessage (e :: SomeException) = do
211-
LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $
212-
ShowMessageParams MtError $ T.unlines
213-
[ "Unhandled exception, please [report](" <> issueTrackerUrl <> "): "
214-
, T.pack(show e)
215-
]
216-
217213
exceptionInHandler e = do
218214
log Error $ LogReactorMessageActionException e
219-
sendErrorMessage e
220215

221216
checkCancelled _id act k =
222217
flip finally (clearReqId _id) $
@@ -235,7 +230,7 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur
235230
exceptionInHandler e
236231
k $ ResponseError InternalError (T.pack $ show e) Nothing
237232
_ <- flip forkFinally handleServerException $ do
238-
untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do
233+
untilMVar lifetime $ runWithDb (cmapWithPrio LogSession lspRecorder) dbLoc $ \withHieDb hieChan -> do
239234
putMVar dbMVar (WithHieDbShield withHieDb,hieChan)
240235
forever $ do
241236
msg <- readChan clientMsgChan

‎ghcide/src/Development/IDE/Main.hs

+11-3
Original file line numberDiff line numberDiff line change
@@ -291,8 +291,12 @@ testing recorder logger =
291291
}
292292

293293

294-
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
295-
defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
294+
defaultMain
295+
:: Recorder (WithPriority Log) -- Recorder to use initially
296+
-> (LSP.LanguageContextEnv Config -> Recorder (WithPriority Log)) -- Recorder to use after the LSP env is ready
297+
-> Arguments
298+
-> IO ()
299+
defaultMain recorder mkLspRecorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
296300
where
297301
log :: Priority -> Log -> IO ()
298302
log = logWith recorder
@@ -325,7 +329,11 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
325329
t <- offsetTime
326330
log Info LogLspStart
327331

328-
runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do
332+
runLanguageServer (cmapWithPrio LogLanguageServer recorder) (fmap (cmapWithPrio LogLanguageServer) mkLspRecorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do
333+
let lspRecorder = mkLspRecorder env
334+
log :: Priority -> Log -> IO ()
335+
log = logWith lspRecorder
336+
329337
traverse_ IO.setCurrentDirectory rootPath
330338
t <- t
331339
log Info $ LogLspStartDuration t

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

+32
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,9 @@ module Development.IDE.Types.Logger
1919
, withDefaultRecorder
2020
, makeDefaultStderrRecorder
2121
, priorityToHsLoggerPriority
22+
, clientShowMessageRecorder
23+
, clientLogMessageRecorder
24+
, makeDefaultClientRecorder
2225
, LoggingColumn(..)
2326
, cmapWithPrio
2427
, module PrettyPrinterModule
@@ -53,6 +56,9 @@ import qualified System.Log.Logger as HsLogger
5356
import UnliftIO (MonadUnliftIO, displayException,
5457
finally, try)
5558

59+
import qualified Language.LSP.Types as LSP
60+
import qualified Language.LSP.Server as LSP
61+
5662
data Priority
5763
-- Don't change the ordering of this type or you will mess up the Ord
5864
-- instance
@@ -137,6 +143,32 @@ cfilter p Recorder{ logger_ } =
137143
Recorder
138144
{ logger_ = \msg -> when (p msg) (logger_ msg) }
139145

146+
logPriorityToMessageType :: Priority -> LSP.MessageType
147+
logPriorityToMessageType prio = case prio of
148+
Error -> LSP.MtError
149+
Warning -> LSP.MtWarning
150+
Info -> LSP.MtInfo
151+
Debug -> LSP.MtLog
152+
153+
-- | Logs messages to the client via @window/logMessage@.
154+
clientLogMessageRecorder :: LSP.LanguageContextEnv config -> Recorder (WithPriority Text)
155+
clientLogMessageRecorder env = Recorder $ \(WithPriority sev _ msg) -> liftIO $ LSP.runLspT env $ do
156+
LSP.sendNotification LSP.SWindowLogMessage (LSP.LogMessageParams (logPriorityToMessageType sev) msg)
157+
158+
-- | Logs messages to the client via @window/showMessage@.
159+
clientShowMessageRecorder :: LSP.LanguageContextEnv config -> Recorder (WithPriority Text)
160+
clientShowMessageRecorder env = Recorder $ \(WithPriority sev _ msg) -> liftIO $ LSP.runLspT env $ do
161+
LSP.sendNotification LSP.SWindowShowMessage (LSP.ShowMessageParams (logPriorityToMessageType sev) msg)
162+
163+
makeDefaultClientRecorder :: LSP.LanguageContextEnv config -> Recorder (WithPriority (Doc a))
164+
makeDefaultClientRecorder env =
165+
cmapWithPrio docToText $
166+
clientLogMessageRecorder env
167+
<>
168+
cfilter (\m -> priority m >= Error) (clientShowMessageRecorder env)
169+
where
170+
docToText = renderStrict . layoutPretty defaultLayoutOptions
171+
140172
textHandleRecorder :: Handle -> Recorder Text
141173
textHandleRecorder handle =
142174
Recorder

‎src/Ide/Main.hs

+18-6
Original file line numberDiff line numberDiff line change
@@ -32,9 +32,11 @@ import Ide.Arguments
3232
import Ide.Logger
3333
import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,
3434
pluginsToVSCodeExtensionSchema)
35+
import Ide.Plugin.Config (Config)
3536
import Ide.Types (IdePlugins, PluginId (PluginId),
3637
ipMap)
3738
import Ide.Version
39+
import qualified Language.LSP.Server as LSP
3840
import System.Directory
3941
import qualified System.Directory.Extra as IO
4042
import System.FilePath
@@ -58,8 +60,13 @@ instance Pretty Log where
5860
, "PluginIds:" <+> pretty (coerce @_ @[Text] pluginIds) ]
5961
LogIDEMain iDEMainLog -> pretty iDEMainLog
6062

61-
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IdePlugins IdeState -> IO ()
62-
defaultMain recorder args idePlugins = do
63+
defaultMain
64+
:: Recorder (WithPriority Log)
65+
-> (LSP.LanguageContextEnv Config -> Recorder (WithPriority Log))
66+
-> Arguments
67+
-> IdePlugins IdeState
68+
-> IO ()
69+
defaultMain recorder lspRecorder args idePlugins = do
6370
-- WARNING: If you write to stdout before runLanguageServer
6471
-- then the language server will not work
6572

@@ -92,7 +99,7 @@ defaultMain recorder args idePlugins = do
9299
Ghcide ghcideArgs -> do
93100
{- see WARNING above -}
94101
logWith recorder Info $ LogVersion hlsVer
95-
runLspMode recorder ghcideArgs idePlugins
102+
runLspMode recorder lspRecorder ghcideArgs idePlugins
96103

97104
VSCodeExtensionSchemaMode -> do
98105
LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins
@@ -120,8 +127,13 @@ hlsLogger = G.Logger $ \pri txt ->
120127

121128
-- ---------------------------------------------------------------------
122129

123-
runLspMode :: Recorder (WithPriority Log) -> GhcideArguments -> IdePlugins IdeState -> IO ()
124-
runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do
130+
runLspMode
131+
:: Recorder (WithPriority Log)
132+
-> (LSP.LanguageContextEnv Config -> Recorder (WithPriority Log))
133+
-> GhcideArguments
134+
-> IdePlugins IdeState
135+
-> IO ()
136+
runLspMode recorder lspRecorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do
125137
let log = logWith recorder
126138
whenJust argsCwd IO.setCurrentDirectory
127139
dir <- IO.getCurrentDirectory
@@ -130,7 +142,7 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog
130142
when (isLSP argsCommand) $ do
131143
log Info $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins)
132144

133-
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsLogger)
145+
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (fmap (cmapWithPrio LogIDEMain) lspRecorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsLogger)
134146
{ IDEMain.argCommand = argsCommand
135147
, IDEMain.argsHlsPlugins = idePlugins
136148
, IDEMain.argsLogger = pure hlsLogger <> pure telemetryLogger

0 commit comments

Comments
 (0)