Skip to content

Commit 613ec40

Browse files
pepeiborrapepeiborra
authored
Improve trace readability (#2319)
1 parent ce1f353 commit 613ec40

File tree

6 files changed

+36
-20
lines changed

6 files changed

+36
-20
lines changed

‎ghcide/exe/Main.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import Development.IDE (Priority (Debug, Info),
1414
action)
1515
import Development.IDE.Core.OfInterest (kick)
1616
import Development.IDE.Core.Rules (mainRule)
17+
import Development.IDE.Core.Tracing (withTelemetryLogger)
1718
import Development.IDE.Graph (ShakeOptions (shakeThreads))
1819
import qualified Development.IDE.Main as Main
1920
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
@@ -39,7 +40,7 @@ ghcideVersion = do
3940
<> gitHashSection
4041

4142
main :: IO ()
42-
main = do
43+
main = withTelemetryLogger $ \telemetryLogger -> do
4344
let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
4445
-- WARNING: If you write to stdout before runLanguageServer
4546
-- then the language server will not work
@@ -55,6 +56,7 @@ main = do
5556

5657
Main.defaultMain arguments
5758
{Main.argCommand = argsCommand
59+
,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger
5860

5961
,Main.argsRules = do
6062
-- install the main and ghcide-plugin rules

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

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -80,6 +80,7 @@ import Control.Concurrent.STM (atomically)
8080
import Control.Concurrent.STM.TQueue
8181
import qualified Data.HashSet as Set
8282
import Database.SQLite.Simple
83+
import Development.IDE.Core.Tracing (withTrace)
8384
import HieDb.Create
8485
import HieDb.Types
8586
import HieDb.Utils
@@ -425,7 +426,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
425426
let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
426427
<> " (for " <> T.pack lfp <> ")"
427428
eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
428-
cradleToOptsAndLibDir logger cradle cfp
429+
withTrace "Load cradle" $ \addTag -> do
430+
addTag "file" lfp
431+
res <- cradleToOptsAndLibDir logger cradle cfp
432+
addTag "result" (show res)
433+
return res
434+
429435

430436
logDebug logger $ T.pack ("Session loading result: " <> show eopts)
431437
case eopts of

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -272,7 +272,10 @@ newtype GetModificationTime = GetModificationTime_
272272
{ missingFileDiagnostics :: Bool
273273
-- ^ If false, missing file diagnostics are not reported
274274
}
275-
deriving (Show, Generic)
275+
deriving (Generic)
276+
277+
instance Show GetModificationTime where
278+
show _ = "GetModificationTime"
276279

277280
instance Eq GetModificationTime where
278281
-- Since the diagnostics are not part of the answer, the query identity is

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

Lines changed: 17 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Development.IDE.Core.Tracing
1212
, otTracedGarbageCollection
1313
, withTrace
1414
, withEventTrace
15+
, withTelemetryLogger
1516
)
1617
where
1718

@@ -34,16 +35,19 @@ import qualified Data.HashMap.Strict as HMap
3435
import Data.IORef (modifyIORef', newIORef,
3536
readIORef, writeIORef)
3637
import Data.String (IsString (fromString))
38+
import qualified Data.Text as T
3739
import Data.Text.Encoding (encodeUtf8)
3840
import Data.Typeable (TypeRep, typeOf)
41+
import Data.Word (Word16)
3942
import Debug.Trace.Flags (userTracingEnabled)
4043
import Development.IDE.Core.RuleTypes (GhcSession (GhcSession),
4144
GhcSessionDeps (GhcSessionDeps),
4245
GhcSessionIO (GhcSessionIO))
4346
import Development.IDE.Graph (Action)
4447
import Development.IDE.Graph.Rule
4548
import Development.IDE.Types.Location (Uri (..))
46-
import Development.IDE.Types.Logger (Logger, logDebug, logInfo)
49+
import Development.IDE.Types.Logger (Logger (Logger), logDebug,
50+
logInfo)
4751
import Development.IDE.Types.Shake (Value,
4852
ValueWithDiagnostics (..),
4953
Values, fromKeyType)
@@ -84,6 +88,18 @@ withEventTrace name act
8488
act (addEvent sp)
8589
| otherwise = act (\_ _ -> pure ())
8690

91+
-- | Returns a logger that produces telemetry events in a single span
92+
withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a
93+
withTelemetryLogger k = withSpan "Logger" $ \sp ->
94+
-- Tracy doesn't like when we create a new span for every log line.
95+
-- To workaround that, we create a single span for all log events.
96+
-- This is fine since we don't care about the span itself, only about the events
97+
k $ Logger $ \p m ->
98+
addEvent sp (fromString $ show p) (encodeUtf8 $ trim m)
99+
where
100+
-- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
101+
trim = T.take (fromIntegral(maxBound :: Word16) - 10)
102+
87103
-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
88104
otTracedHandler
89105
:: MonadUnliftIO m

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

Lines changed: 2 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -23,14 +23,11 @@ import Data.Hashable (hashed)
2323
import Data.List.Extra (intercalate, isPrefixOf,
2424
nub, nubOrd, partition)
2525
import Data.Maybe (catMaybes, isJust)
26-
import Data.String
2726
import qualified Data.Text as T
28-
import Data.Text.Encoding (encodeUtf8)
2927
import qualified Data.Text.IO as T
3028
import Data.Text.Lazy.Encoding (decodeUtf8)
3129
import qualified Data.Text.Lazy.IO as LT
3230
import Data.Typeable (typeOf)
33-
import Data.Word (Word16)
3431
import Development.IDE (Action, GhcVersion (..),
3532
Priority (Debug), Rules,
3633
ghcVersion,
@@ -55,8 +52,7 @@ import Development.IDE.Core.Service (initialise, runAction)
5552
import Development.IDE.Core.Shake (IdeState (shakeExtras),
5653
ShakeExtras (state),
5754
shakeSessionInit, uses)
58-
import Development.IDE.Core.Tracing (measureMemory,
59-
withEventTrace)
55+
import Development.IDE.Core.Tracing (measureMemory)
6056
import Development.IDE.Graph (action)
6157
import Development.IDE.LSP.LanguageServer (runLanguageServer)
6258
import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))
@@ -190,7 +186,7 @@ defaultArguments :: Priority -> Arguments
190186
defaultArguments priority = Arguments
191187
{ argsOTMemoryProfiling = False
192188
, argCommand = LSP
193-
, argsLogger = stderrLogger priority <> pure telemetryLogger
189+
, argsLogger = stderrLogger priority
194190
, argsRules = mainRule >> action kick
195191
, argsGhcidePlugin = mempty
196192
, argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors
@@ -240,14 +236,6 @@ stderrLogger logLevel = do
240236
return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $
241237
T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m
242238

243-
telemetryLogger :: Logger
244-
telemetryLogger = Logger $ \p m ->
245-
withEventTrace "Log" $ \addEvent ->
246-
addEvent (fromString $ "Log " <> show p) (encodeUtf8 $ trim m)
247-
where
248-
-- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
249-
trim = T.take (fromIntegral(maxBound :: Word16) - 10)
250-
251239
defaultMain :: Arguments -> IO ()
252240
defaultMain Arguments{..} = do
253241
setLocaleEncoding utf8

‎src/Ide/Main.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import Data.Default
1616
import Data.List (sort)
1717
import qualified Data.Text as T
1818
import Development.IDE.Core.Rules
19+
import Development.IDE.Core.Tracing (withTelemetryLogger)
1920
import Development.IDE.Graph (ShakeOptions (shakeThreads))
2021
import Development.IDE.Main (isLSP)
2122
import qualified Development.IDE.Main as Main
@@ -90,7 +91,7 @@ hlsLogger = G.Logger $ \pri txt ->
9091
-- ---------------------------------------------------------------------
9192

9293
runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO ()
93-
runLspMode ghcideArgs@GhcideArguments{..} idePlugins = do
94+
runLspMode ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do
9495
whenJust argsCwd IO.setCurrentDirectory
9596
dir <- IO.getCurrentDirectory
9697
LSP.setupLogger argsLogFile ["hls", "hie-bios"]
@@ -105,7 +106,7 @@ runLspMode ghcideArgs@GhcideArguments{..} idePlugins = do
105106
Main.defaultMain def
106107
{ Main.argCommand = argsCommand
107108
, Main.argsHlsPlugins = idePlugins
108-
, Main.argsLogger = pure hlsLogger
109+
, Main.argsLogger = pure hlsLogger <> pure telemetryLogger
109110
, Main.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads
110111
, Main.argsIdeOptions = \_config sessionLoader ->
111112
let defOptions = Ghcide.defaultIdeOptions sessionLoader

0 commit comments

Comments
 (0)