Add traces for HLS providers

ghcide/.hlint.yaml

@@ -78,6 +78,7 @@
     - Development.IDE.Core.FileStore
     - Development.IDE.Core.Compile
     - Development.IDE.Core.Rules
+    - Development.IDE.Core.Tracing
     - Development.IDE.GHC.Compat
     - Development.IDE.GHC.ExactPrint
     - Development.IDE.GHC.Orphans

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

@@ -1,11 +1,13 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+#include "ghc-api-version.h"
 module Development.IDE.Core.Tracing
     ( otTracedHandler
     , otTracedAction
     , startTelemetry
     , measureMemory
     , getInstrumentCached
-    )
+    ,otTracedProvider,otSetUri)
 where
 
 import           Control.Concurrent.Async       (Async, async)
@@ -33,23 +35,30 @@ import           HeapSize                       (recursiveSize, runHeapsize)
 import           Language.Haskell.LSP.Types     (NormalizedFilePath,
                                                  fromNormalizedFilePath)
 import           Numeric.Natural                (Natural)
-import           OpenTelemetry.Eventlog         (Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan,
+import           OpenTelemetry.Eventlog         (SpanInFlight, Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan,
                                                  mkValueObserver, observe,
                                                  setTag, withSpan, withSpan_)
+import Data.ByteString (ByteString)
+import Data.Text.Encoding (encodeUtf8)
+import Ide.Types (PluginId (..))
+import Development.IDE.Types.Location (Uri (..))
 
 -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
 otTracedHandler
     :: String -- ^ Message type
     -> String -- ^ Message label
-    -> IO a
+    -> (SpanInFlight -> IO a)
     -> IO a
 otTracedHandler requestType label act =
   let !name =
         if null label
           then requestType
           else requestType <> ":" <> show label
    -- Add an event so all requests can be quickly seen in the viewer without searching
-   in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act)
+   in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act sp)
+
+otSetUri :: SpanInFlight -> Uri -> IO ()
+otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)
 
 -- | Trace a Shake action using opentelemetry.
 otTracedAction
@@ -71,6 +80,16 @@ otTracedAction key file success act = actionBracket
         unless (success res) $ setTag sp "error" "1"
         return res)
 
+#if MIN_GHC_API_VERSION(8,8,0)
+otTracedProvider :: PluginId -> ByteString -> IO a -> IO a
+#else
+otTracedProvider :: PluginId -> String -> IO a -> IO a
+#endif
+otTracedProvider (PluginId pluginName) provider act =
+  withSpan (provider <> " provider") $ \sp -> do
+    setTag sp "plugin" (encodeUtf8 pluginName)
+    act
+
 startTelemetry :: Bool -> Logger -> Var Values -> IO ()
 startTelemetry allTheTime logger stateRef = do
     instrumentFor <- getInstrumentCached

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

@@ -147,21 +147,25 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
                 -- We dispatch notifications synchronously and requests asynchronously
                 -- This is to ensure that all file edits and config changes are applied before a request is handled
                 case msg of
-                    Notification x@NotificationMessage{_params, _method} act -> otTracedHandler "Notification" (show _method) $ do
-                        catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
+                    Notification x@NotificationMessage{_params, _method} act ->
+                        otTracedHandler "Notification" (show _method) $ \sp -> do
+                          traceWithSpan sp _params
+                          catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
                             logError (ideLogger ide) $ T.pack $
                                 "Unexpected exception on notification, please report!\n" ++
                                 "Message: " ++ show x ++ "\n" ++
                                 "Exception: " ++ show e
                     Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $
-                        otTracedHandler "Request" (show _method) $
-                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
+                        otTracedHandler "Request" (show _method) $ \sp -> do
+                          traceWithSpan sp _params
+                          checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
                             \case
                               Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
                               Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
                     ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $
-                        otTracedHandler "Request" (show _method) $
-                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
+                        otTracedHandler "Request" (show _method) $ \sp -> do
+                          traceWithSpan sp _params
+                          checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
                             \(res, newReq) -> do
                                 case res of
                                     Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
@@ -170,8 +174,9 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
                                     reqId <- getNextReqId
                                     sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
                     InitialParams x@RequestMessage{_id, _method, _params} act ->
-                        otTracedHandler "Initialize" (show _method) $
-                        catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
+                        otTracedHandler "Initialize" (show _method) $ \sp -> do
+                          traceWithSpan sp _params
+                          catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
                             logError (ideLogger ide) $ T.pack $
                                 "Unexpected exception on InitializeRequest handler, please report!\n" ++
                                 "Message: " ++ show x ++ "\n" ++
@@ -238,14 +243,17 @@ exitHandler exit = PartialHandlers $ \_ x -> return x
 -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
 --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
 data Message c
-    = 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))
-    -- | Used for cases in which we need to send not only a response,
+  = forall m req resp . (Show m, Show req, HasTracing req) =>
+    Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
+  | -- | Used for cases in which we need to send not only a response,
     --   but also an additional request to the client.
     --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
-    | 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)))
-    | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
-    -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
-    | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
+    forall m rm req resp newReqParams newReqBody. (Show m, Show rm, Show req, HasTracing 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)))
+  | forall m req . (Show m, Show req, HasTracing req) =>
+    Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
+  | -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
+    InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
 
 modifyOptions :: LSP.Options -> LSP.Options
 modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
@@ -6,27 +8,33 @@
 module Development.IDE.LSP.Server
   ( WithMessage(..)
   , PartialHandlers(..)
-  ) where
+  , HasTracing(..)
+  ,setUriAnd) where
 
 
+import Control.Lens ((^.))
 import Data.Default
 
 import           Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Core as LSP
 import qualified Language.Haskell.LSP.Messages as LSP
+import Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri (uri))
 import Development.IDE.Core.Service
+import Data.Aeson (Value)
+import Development.IDE.Core.Tracing (otSetUri)
+import OpenTelemetry.Eventlog (SpanInFlight)
 
 data WithMessage c = WithMessage
-    {withResponse :: forall m req resp . (Show m, Show req) =>
+    {withResponse :: forall m req resp . (Show m, Show req, HasTracing req) =>
         (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
         (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
         Maybe (LSP.Handler (RequestMessage m req resp))
-    ,withNotification :: forall m req . (Show m, Show req) =>
+    ,withNotification :: forall m req . (Show m, Show req, HasTracing req) =>
         Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
         (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work
         Maybe (LSP.Handler (NotificationMessage m req))
     ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
-        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
+        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody, HasTracing req) =>
         (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
         (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
         (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work
@@ -45,3 +53,30 @@ instance Semigroup (PartialHandlers c) where
 
 instance Monoid (PartialHandlers c) where
     mempty = def
+
+class HasTracing a where
+  traceWithSpan :: SpanInFlight -> a -> IO ()
+  traceWithSpan _ _ = pure ()
+
+instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where
+  traceWithSpan sp a = otSetUri sp (a ^. textDocument . uri)
+
+instance HasTracing Value
+instance HasTracing ExecuteCommandParams
+instance HasTracing DidChangeWatchedFilesParams
+instance HasTracing DidChangeWorkspaceFoldersParams
+instance HasTracing DidChangeConfigurationParams
+instance HasTracing InitializeParams
+instance HasTracing (Maybe InitializedParams)
+
+setUriAnd ::
+  (HasTextDocument params a, HasUri a Uri) =>
+  (lspFuncs -> ide -> params -> IO res) ->
+  lspFuncs ->
+  SpanInFlight ->
+  ide ->
+  params ->
+  IO res
+setUriAnd k lf sp ide params = do
+  otSetUri sp (params ^. textDocument . uri)
+  k lf ide params

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

@@ -32,6 +32,7 @@ import           Text.Regex.TDFA.Text()
 import Development.Shake (Rules)
 import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)
 import Development.IDE.Types.Logger (logInfo)
+import Development.IDE.Core.Tracing
 
 -- ---------------------------------------------------------------------
 
@@ -94,7 +95,7 @@ makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do
         makeAction (pid,provider) = do
           pluginConfig <- getPluginConfig lf pid
           if pluginEnabled pluginConfig plcCodeActionsOn
-            then provider lf ideState pid docId range context
+            then otTracedProvider pid "codeAction" $ provider lf ideState pid docId range context
             else return $ Right (List [])
     r <- mapM makeAction cas
     let actions = filter wasRequested . foldMap unL $ rights r
@@ -158,7 +159,7 @@ makeCodeLens cas lf ideState params = do
       makeLens (pid, provider) = do
           pluginConfig <- getPluginConfig lf pid
           r <- if pluginEnabled pluginConfig plcCodeLensOn
-                 then provider lf ideState pid params
+                 then otTracedProvider pid "codeLens" $ provider lf ideState pid params
                  else return $ Right (List [])
           return (pid, r)
       breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)])
@@ -303,7 +304,7 @@ makeHover hps lf ideState params
         makeHover(pid,p) = do
           pluginConfig <- getPluginConfig lf pid
           if pluginEnabled pluginConfig plcHoverOn
-             then p ideState params
+             then otTracedProvider pid "hover" $ p ideState params
              else return $ Right Nothing
       mhs <- mapM makeHover hps
       -- TODO: We should support ServerCapabilities and declare that
@@ -358,7 +359,7 @@ makeSymbols sps lf ideState params
           makeSymbols (pid,p) = do
             pluginConfig <- getPluginConfig lf pid
             if pluginEnabled pluginConfig plcSymbolsOn
-              then p lf ideState params
+              then otTracedProvider pid "symbols" $ p lf ideState params
               else return $ Right []
       mhs <- mapM makeSymbols sps
       case rights mhs of
@@ -387,7 +388,7 @@ renameWith providers lspFuncs state params = do
         makeAction (pid,p) = do
           pluginConfig <- getPluginConfig lspFuncs pid
           if pluginEnabled pluginConfig plcRenameOn
-             then p lspFuncs state params
+             then otTracedProvider pid "rename" $ p lspFuncs state params
              else return $ Right $ WorkspaceEdit Nothing Nothing
     -- TODO:AZ: we need to consider the right way to combine possible renamers
     results <- mapM makeAction providers
@@ -453,7 +454,7 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier
           makeAction (pid,p) = do
             pluginConfig <- getPluginConfig lf pid
             if pluginEnabled pluginConfig plcCompletionOn
-               then p lf ideState params
+               then otTracedProvider pid "completions" $ p lf ideState params
                else return $ Right $ Completions $ List []
 
       case mprefix of