diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 587b18f8ca..78af32e8ba 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 a0af4d235a..39643d1ab8 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 b7ceb89d22..6f8900b54e 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 d81c90d883..e3c8ee3895 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 cb084ef11f..a732fcd6fb 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 10939035ef..e4b7cec41e 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