Improve trace readability (#2319)

Author: pepeiborra

ghcide/exe/Main.hs

@@ -14,6 +14,7 @@ import           Development.IDE                   (Priority (Debug, Info),
                                                     action)
 import           Development.IDE.Core.OfInterest   (kick)
 import           Development.IDE.Core.Rules        (mainRule)
+import           Development.IDE.Core.Tracing      (withTelemetryLogger)
 import           Development.IDE.Graph             (ShakeOptions (shakeThreads))
 import qualified Development.IDE.Main              as Main
 import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
@@ -39,7 +40,7 @@ ghcideVersion = do
              <> gitHashSection
 
 main :: IO ()
-main = do
+main = withTelemetryLogger $ \telemetryLogger -> do
     let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
     -- WARNING: If you write to stdout before runLanguageServer
     --          then the language server will not work
@@ -55,6 +56,7 @@ main = do
 
     Main.defaultMain arguments
         {Main.argCommand = argsCommand
+        ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger
 
         ,Main.argsRules = do
             -- install the main and ghcide-plugin rules

ghcide/session-loader/Development/IDE/Session.hs

@@ -80,6 +80,7 @@ import           Control.Concurrent.STM               (atomically)
 import           Control.Concurrent.STM.TQueue
 import qualified Data.HashSet                         as Set
 import           Database.SQLite.Simple
+import           Development.IDE.Core.Tracing         (withTrace)
 import           HieDb.Create
 import           HieDb.Types
 import           HieDb.Utils
@@ -425,7 +426,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
            let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
                          <> " (for " <> T.pack lfp <> ")"
            eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
-              cradleToOptsAndLibDir logger cradle cfp
+              withTrace "Load cradle" $ \addTag -> do
+                  addTag "file" lfp
+                  res <- cradleToOptsAndLibDir logger cradle cfp
+                  addTag "result" (show res)
+                  return res
+
 
            logDebug logger $ T.pack ("Session loading result: " <> show eopts)
            case eopts of

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

@@ -272,7 +272,10 @@ newtype GetModificationTime = GetModificationTime_
     { missingFileDiagnostics :: Bool
       -- ^ If false, missing file diagnostics are not reported
     }
-    deriving (Show, Generic)
+    deriving (Generic)
+
+instance Show GetModificationTime where
+    show _ = "GetModificationTime"
 
 instance Eq GetModificationTime where
     -- Since the diagnostics are not part of the answer, the query identity is

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

@@ -12,6 +12,7 @@ module Development.IDE.Core.Tracing
     , otTracedGarbageCollection
     , withTrace
     , withEventTrace
+    , withTelemetryLogger
     )
 where
 
@@ -34,16 +35,19 @@ import qualified Data.HashMap.Strict            as HMap
 import           Data.IORef                     (modifyIORef', newIORef,
                                                  readIORef, writeIORef)
 import           Data.String                    (IsString (fromString))
+import qualified Data.Text                      as T
 import           Data.Text.Encoding             (encodeUtf8)
 import           Data.Typeable                  (TypeRep, typeOf)
+import           Data.Word                      (Word16)
 import           Debug.Trace.Flags              (userTracingEnabled)
 import           Development.IDE.Core.RuleTypes (GhcSession (GhcSession),
                                                  GhcSessionDeps (GhcSessionDeps),
                                                  GhcSessionIO (GhcSessionIO))
 import           Development.IDE.Graph          (Action)
 import           Development.IDE.Graph.Rule
 import           Development.IDE.Types.Location (Uri (..))
-import           Development.IDE.Types.Logger   (Logger, logDebug, logInfo)
+import           Development.IDE.Types.Logger   (Logger (Logger), logDebug,
+                                                 logInfo)
 import           Development.IDE.Types.Shake    (Value,
                                                  ValueWithDiagnostics (..),
                                                  Values, fromKeyType)
@@ -84,6 +88,18 @@ withEventTrace name act
       act (addEvent sp)
   | otherwise = act (\_ _ -> pure ())
 
+-- | Returns a logger that produces telemetry events in a single span
+withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a
+withTelemetryLogger k = withSpan "Logger" $ \sp ->
+    -- Tracy doesn't like when we create a new span for every log line.
+    -- To workaround that, we create a single span for all log events.
+    -- This is fine since we don't care about the span itself, only about the events
+    k $ Logger $ \p m ->
+            addEvent sp (fromString $ show p) (encodeUtf8 $ trim m)
+    where
+        -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
+        trim = T.take (fromIntegral(maxBound :: Word16) - 10)
+
 -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
 otTracedHandler
     :: MonadUnliftIO m

ghcide/src/Development/IDE/Main.hs

@@ -23,14 +23,11 @@ import           Data.Hashable                         (hashed)
 import           Data.List.Extra                       (intercalate, isPrefixOf,
                                                         nub, nubOrd, partition)
 import           Data.Maybe                            (catMaybes, isJust)
-import           Data.String
 import qualified Data.Text                             as T
-import           Data.Text.Encoding                    (encodeUtf8)
 import qualified Data.Text.IO                          as T
 import           Data.Text.Lazy.Encoding               (decodeUtf8)
 import qualified Data.Text.Lazy.IO                     as LT
 import           Data.Typeable                         (typeOf)
-import           Data.Word                             (Word16)
 import           Development.IDE                       (Action, GhcVersion (..),
                                                         Priority (Debug), Rules,
                                                         ghcVersion,
@@ -55,8 +52,7 @@ import           Development.IDE.Core.Service          (initialise, runAction)
 import           Development.IDE.Core.Shake            (IdeState (shakeExtras),
                                                         ShakeExtras (state),
                                                         shakeSessionInit, uses)
-import           Development.IDE.Core.Tracing          (measureMemory,
-                                                        withEventTrace)
+import           Development.IDE.Core.Tracing          (measureMemory)
 import           Development.IDE.Graph                 (action)
 import           Development.IDE.LSP.LanguageServer    (runLanguageServer)
 import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))
@@ -190,7 +186,7 @@ defaultArguments :: Priority -> Arguments
 defaultArguments priority = Arguments
         { argsOTMemoryProfiling = False
         , argCommand = LSP
-        , argsLogger = stderrLogger priority <> pure telemetryLogger
+        , argsLogger = stderrLogger priority
         , argsRules = mainRule >> action kick
         , argsGhcidePlugin = mempty
         , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors
@@ -240,14 +236,6 @@ stderrLogger logLevel = do
     return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $
         T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m
 
-telemetryLogger :: Logger
-telemetryLogger = Logger $ \p m ->
-        withEventTrace "Log" $ \addEvent ->
-            addEvent (fromString $ "Log " <> show p) (encodeUtf8 $ trim m)
-    where
-        -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
-        trim = T.take (fromIntegral(maxBound :: Word16) - 10)
-
 defaultMain :: Arguments -> IO ()
 defaultMain Arguments{..} = do
     setLocaleEncoding utf8

src/Ide/Main.hs

@@ -16,6 +16,7 @@ import           Data.Default
 import           Data.List                     (sort)
 import qualified Data.Text                     as T
 import           Development.IDE.Core.Rules
+import           Development.IDE.Core.Tracing  (withTelemetryLogger)
 import           Development.IDE.Graph         (ShakeOptions (shakeThreads))
 import           Development.IDE.Main          (isLSP)
 import qualified Development.IDE.Main          as Main
@@ -90,7 +91,7 @@ hlsLogger = G.Logger $ \pri txt ->
 -- ---------------------------------------------------------------------
 
 runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO ()
-runLspMode ghcideArgs@GhcideArguments{..} idePlugins = do
+runLspMode ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do
     whenJust argsCwd IO.setCurrentDirectory
     dir <- IO.getCurrentDirectory
     LSP.setupLogger argsLogFile ["hls", "hie-bios"]
@@ -105,7 +106,7 @@ runLspMode ghcideArgs@GhcideArguments{..} idePlugins = do
     Main.defaultMain def
       { Main.argCommand = argsCommand
       , Main.argsHlsPlugins = idePlugins
-      , Main.argsLogger = pure hlsLogger
+      , Main.argsLogger = pure hlsLogger <> pure telemetryLogger
       , Main.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads
       , Main.argsIdeOptions = \_config sessionLoader ->
         let defOptions = Ghcide.defaultIdeOptions sessionLoader