Skip to content

Commit 3278d53

Browse files
pepeiborramergify[bot]
pepeiborra
and
mergify[bot]
authored
Add traces for HLS providers (#1222)
* Add tracing for HLS plugins * Include URIs in handler traces * Compat with ghc 8.6 Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 0403dbf commit 3278d53

File tree

5 files changed

+92
-28
lines changed

5 files changed

+92
-28
lines changed

‎ghcide/.hlint.yaml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -78,6 +78,7 @@
7878
- Development.IDE.Core.FileStore
7979
- Development.IDE.Core.Compile
8080
- Development.IDE.Core.Rules
81+
- Development.IDE.Core.Tracing
8182
- Development.IDE.GHC.Compat
8283
- Development.IDE.GHC.ExactPrint
8384
- Development.IDE.GHC.Orphans

‎ghcide/src/Development/IDE/Core/Tracing.hs

Lines changed: 23 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,13 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE DataKinds #-}
3+
#include "ghc-api-version.h"
24
module Development.IDE.Core.Tracing
35
( otTracedHandler
46
, otTracedAction
57
, startTelemetry
68
, measureMemory
79
, getInstrumentCached
8-
)
10+
,otTracedProvider,otSetUri)
911
where
1012

1113
import Control.Concurrent.Async (Async, async)
@@ -33,23 +35,30 @@ import HeapSize (recursiveSize, runHeapsize)
3335
import Language.Haskell.LSP.Types (NormalizedFilePath,
3436
fromNormalizedFilePath)
3537
import Numeric.Natural (Natural)
36-
import OpenTelemetry.Eventlog (Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan,
38+
import OpenTelemetry.Eventlog (SpanInFlight, Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan,
3739
mkValueObserver, observe,
3840
setTag, withSpan, withSpan_)
41+
import Data.ByteString (ByteString)
42+
import Data.Text.Encoding (encodeUtf8)
43+
import Ide.Types (PluginId (..))
44+
import Development.IDE.Types.Location (Uri (..))
3945

4046
-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
4147
otTracedHandler
4248
:: String -- ^ Message type
4349
-> String -- ^ Message label
44-
-> IO a
50+
-> (SpanInFlight -> IO a)
4551
-> IO a
4652
otTracedHandler requestType label act =
4753
let !name =
4854
if null label
4955
then requestType
5056
else requestType <> ":" <> show label
5157
-- Add an event so all requests can be quickly seen in the viewer without searching
52-
in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act)
58+
in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act sp)
59+
60+
otSetUri :: SpanInFlight -> Uri -> IO ()
61+
otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)
5362

5463
-- | Trace a Shake action using opentelemetry.
5564
otTracedAction
@@ -71,6 +80,16 @@ otTracedAction key file success act = actionBracket
7180
unless (success res) $ setTag sp "error" "1"
7281
return res)
7382

83+
#if MIN_GHC_API_VERSION(8,8,0)
84+
otTracedProvider :: PluginId -> ByteString -> IO a -> IO a
85+
#else
86+
otTracedProvider :: PluginId -> String -> IO a -> IO a
87+
#endif
88+
otTracedProvider (PluginId pluginName) provider act =
89+
withSpan (provider <> " provider") $ \sp -> do
90+
setTag sp "plugin" (encodeUtf8 pluginName)
91+
act
92+
7493
startTelemetry :: Bool -> Logger -> Var Values -> IO ()
7594
startTelemetry allTheTime logger stateRef = do
7695
instrumentFor <- getInstrumentCached

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

Lines changed: 22 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -147,21 +147,25 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
147147
-- We dispatch notifications synchronously and requests asynchronously
148148
-- This is to ensure that all file edits and config changes are applied before a request is handled
149149
case msg of
150-
Notification x@NotificationMessage{_params, _method} act -> otTracedHandler "Notification" (show _method) $ do
151-
catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
150+
Notification x@NotificationMessage{_params, _method} act ->
151+
otTracedHandler "Notification" (show _method) $ \sp -> do
152+
traceWithSpan sp _params
153+
catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
152154
logError (ideLogger ide) $ T.pack $
153155
"Unexpected exception on notification, please report!\n" ++
154156
"Message: " ++ show x ++ "\n" ++
155157
"Exception: " ++ show e
156158
Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $
157-
otTracedHandler "Request" (show _method) $
158-
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
159+
otTracedHandler "Request" (show _method) $ \sp -> do
160+
traceWithSpan sp _params
161+
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
159162
\case
160163
Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
161164
Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
162165
ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $
163-
otTracedHandler "Request" (show _method) $
164-
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
166+
otTracedHandler "Request" (show _method) $ \sp -> do
167+
traceWithSpan sp _params
168+
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
165169
\(res, newReq) -> do
166170
case res of
167171
Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
@@ -170,8 +174,9 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
170174
reqId <- getNextReqId
171175
sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
172176
InitialParams x@RequestMessage{_id, _method, _params} act ->
173-
otTracedHandler "Initialize" (show _method) $
174-
catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
177+
otTracedHandler "Initialize" (show _method) $ \sp -> do
178+
traceWithSpan sp _params
179+
catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
175180
logError (ideLogger ide) $ T.pack $
176181
"Unexpected exception on InitializeRequest handler, please report!\n" ++
177182
"Message: " ++ show x ++ "\n" ++
@@ -238,14 +243,17 @@ exitHandler exit = PartialHandlers $ \_ x -> return x
238243
-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
239244
-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
240245
data Message c
241-
= forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
242-
-- | Used for cases in which we need to send not only a response,
246+
= forall m req resp . (Show m, Show req, HasTracing req) =>
247+
Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
248+
| -- | Used for cases in which we need to send not only a response,
243249
-- but also an additional request to the client.
244250
-- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
245-
| forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
246-
| forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
247-
-- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
248-
| InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
251+
forall m rm req resp newReqParams newReqBody. (Show m, Show rm, Show req, HasTracing req) =>
252+
ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
253+
| forall m req . (Show m, Show req, HasTracing req) =>
254+
Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
255+
| -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
256+
InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
249257

250258
modifyOptions :: LSP.Options -> LSP.Options
251259
modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS

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

Lines changed: 39 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE FlexibleInstances #-}
2+
{-# LANGUAGE UndecidableInstances #-}
13
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
24
-- SPDX-License-Identifier: Apache-2.0
35

@@ -6,27 +8,33 @@
68
module Development.IDE.LSP.Server
79
( WithMessage(..)
810
, PartialHandlers(..)
9-
) where
11+
, HasTracing(..)
12+
,setUriAnd) where
1013

1114

15+
import Control.Lens ((^.))
1216
import Data.Default
1317

1418
import Language.Haskell.LSP.Types
1519
import qualified Language.Haskell.LSP.Core as LSP
1620
import qualified Language.Haskell.LSP.Messages as LSP
21+
import Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri (uri))
1722
import Development.IDE.Core.Service
23+
import Data.Aeson (Value)
24+
import Development.IDE.Core.Tracing (otSetUri)
25+
import OpenTelemetry.Eventlog (SpanInFlight)
1826

1927
data WithMessage c = WithMessage
20-
{withResponse :: forall m req resp . (Show m, Show req) =>
28+
{withResponse :: forall m req resp . (Show m, Show req, HasTracing req) =>
2129
(ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
2230
(LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
2331
Maybe (LSP.Handler (RequestMessage m req resp))
24-
,withNotification :: forall m req . (Show m, Show req) =>
32+
,withNotification :: forall m req . (Show m, Show req, HasTracing req) =>
2533
Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
2634
(LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work
2735
Maybe (LSP.Handler (NotificationMessage m req))
2836
,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
29-
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
37+
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody, HasTracing req) =>
3038
(ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
3139
(RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
3240
(LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work
@@ -45,3 +53,30 @@ instance Semigroup (PartialHandlers c) where
4553

4654
instance Monoid (PartialHandlers c) where
4755
mempty = def
56+
57+
class HasTracing a where
58+
traceWithSpan :: SpanInFlight -> a -> IO ()
59+
traceWithSpan _ _ = pure ()
60+
61+
instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where
62+
traceWithSpan sp a = otSetUri sp (a ^. textDocument . uri)
63+
64+
instance HasTracing Value
65+
instance HasTracing ExecuteCommandParams
66+
instance HasTracing DidChangeWatchedFilesParams
67+
instance HasTracing DidChangeWorkspaceFoldersParams
68+
instance HasTracing DidChangeConfigurationParams
69+
instance HasTracing InitializeParams
70+
instance HasTracing (Maybe InitializedParams)
71+
72+
setUriAnd ::
73+
(HasTextDocument params a, HasUri a Uri) =>
74+
(lspFuncs -> ide -> params -> IO res) ->
75+
lspFuncs ->
76+
SpanInFlight ->
77+
ide ->
78+
params ->
79+
IO res
80+
setUriAnd k lf sp ide params = do
81+
otSetUri sp (params ^. textDocument . uri)
82+
k lf ide params

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

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Text.Regex.TDFA.Text()
3232
import Development.Shake (Rules)
3333
import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)
3434
import Development.IDE.Types.Logger (logInfo)
35+
import Development.IDE.Core.Tracing
3536

3637
-- ---------------------------------------------------------------------
3738

@@ -94,7 +95,7 @@ makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do
9495
makeAction (pid,provider) = do
9596
pluginConfig <- getPluginConfig lf pid
9697
if pluginEnabled pluginConfig plcCodeActionsOn
97-
then provider lf ideState pid docId range context
98+
then otTracedProvider pid "codeAction" $ provider lf ideState pid docId range context
9899
else return $ Right (List [])
99100
r <- mapM makeAction cas
100101
let actions = filter wasRequested . foldMap unL $ rights r
@@ -158,7 +159,7 @@ makeCodeLens cas lf ideState params = do
158159
makeLens (pid, provider) = do
159160
pluginConfig <- getPluginConfig lf pid
160161
r <- if pluginEnabled pluginConfig plcCodeLensOn
161-
then provider lf ideState pid params
162+
then otTracedProvider pid "codeLens" $ provider lf ideState pid params
162163
else return $ Right (List [])
163164
return (pid, r)
164165
breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)])
@@ -303,7 +304,7 @@ makeHover hps lf ideState params
303304
makeHover(pid,p) = do
304305
pluginConfig <- getPluginConfig lf pid
305306
if pluginEnabled pluginConfig plcHoverOn
306-
then p ideState params
307+
then otTracedProvider pid "hover" $ p ideState params
307308
else return $ Right Nothing
308309
mhs <- mapM makeHover hps
309310
-- TODO: We should support ServerCapabilities and declare that
@@ -358,7 +359,7 @@ makeSymbols sps lf ideState params
358359
makeSymbols (pid,p) = do
359360
pluginConfig <- getPluginConfig lf pid
360361
if pluginEnabled pluginConfig plcSymbolsOn
361-
then p lf ideState params
362+
then otTracedProvider pid "symbols" $ p lf ideState params
362363
else return $ Right []
363364
mhs <- mapM makeSymbols sps
364365
case rights mhs of
@@ -387,7 +388,7 @@ renameWith providers lspFuncs state params = do
387388
makeAction (pid,p) = do
388389
pluginConfig <- getPluginConfig lspFuncs pid
389390
if pluginEnabled pluginConfig plcRenameOn
390-
then p lspFuncs state params
391+
then otTracedProvider pid "rename" $ p lspFuncs state params
391392
else return $ Right $ WorkspaceEdit Nothing Nothing
392393
-- TODO:AZ: we need to consider the right way to combine possible renamers
393394
results <- mapM makeAction providers
@@ -453,7 +454,7 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier
453454
makeAction (pid,p) = do
454455
pluginConfig <- getPluginConfig lf pid
455456
if pluginEnabled pluginConfig plcCompletionOn
456-
then p lf ideState params
457+
then otTracedProvider pid "completions" $ p lf ideState params
457458
else return $ Right $ Completions $ List []
458459

459460
case mprefix of

0 commit comments

Comments
 (0)