diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs
index 587b18f8ca6d6e47f9afbfe278f27d18d0b019db..78af32e8ba33c3d47ddce6ee5e2f70bd85f4d832 100644
--- a/ghcide/exe/Main.hs
+++ b/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
diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs
index a0af4d235affc53ad658152a118eff8df3e9cd10..39643d1ab8746597644de02716f3bfb04deff07f 100644
--- a/ghcide/session-loader/Development/IDE/Session.hs
+++ b/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
diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs
index b7ceb89d226c3d8cc2ed9a28a57122c04f69372e..6f8900b54e9fd172ca0fae23dffe29145fb11531 100644
--- a/ghcide/src/Development/IDE/Core/RuleTypes.hs
+++ b/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
diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs
index d81c90d883066bf25f618e0938a64f2ad0a50356..e3c8ee389585c4846d5c946f830d3cb84991bc29 100644
--- a/ghcide/src/Development/IDE/Core/Tracing.hs
+++ b/ghcide/src/Development/IDE/Core/Tracing.hs
@@ -12,6 +12,7 @@ module Development.IDE.Core.Tracing
, otTracedGarbageCollection
, withTrace
, withEventTrace
+ , withTelemetryLogger
)
where
@@ -34,8 +35,10 @@ 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),
@@ -43,7 +46,8 @@ import Development.IDE.Core.RuleTypes (GhcSession (GhcSession),
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
diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs
index cb084ef11f2483c6b52ff89b83d5df692a0484af..a732fcd6fba2536618edc2f873c93860b0d6e4cb 100644
--- a/ghcide/src/Development/IDE/Main.hs
+++ b/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
diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs
index 10939035ef9cca01bb4ce91953e09d8fd22fd4da..e4b7cec41eb1725086683c5f4fb1c6c0ed8ba3ad 100644
--- a/src/Ide/Main.hs
+++ b/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