diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 0698fbe98d..587b18f8ca 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -8,16 +8,15 @@ module Main(main) where import Arguments (Arguments (..), getArguments) import Control.Monad.Extra (unless, whenJust) -import Data.Default (Default (def)) import Data.Version (showVersion) import Development.GitRev (gitHash) -import Development.IDE (action) +import Development.IDE (Priority (Debug, Info), + action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) @@ -51,7 +50,8 @@ main = do whenJust argsCwd IO.setCurrentDirectory - let arguments = if argsTesting then Main.testing else def + let logPriority = if argsVerbose then Debug else Info + arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority Main.defaultMain arguments {Main.argCommand = argsCommand diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 28649971f6..880d9f456d 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -80,7 +80,7 @@ addFileOfInterest state f v = do OfInterestVar var <- getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (, Just v) f dict - pure (new, (prev, dict)) + pure (new, (prev, new)) when (prev /= Just v) $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f20d9d6883..99c0cfb71a 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -150,6 +150,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.IORef.Extra (atomicModifyIORef'_, atomicModifyIORef_) +import Data.String (fromString) import Data.Text (pack) import qualified Development.IDE.Types.Exports as ExportsMap import HieDb.Types @@ -546,7 +547,7 @@ shakeOpen lspEnv defaultConfig logger debouncer -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () shakeSessionInit IdeState{..} = do - initSession <- newSession shakeExtras shakeDb [] + initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit" putMVar shakeSession initSession shakeShut :: IdeState -> IO () @@ -606,7 +607,7 @@ shakeRestart IdeState{..} reason acts = -- between spawning the new thread and updating shakeSession. -- See https://github.com/haskell/ghcide/issues/79 (\() -> do - (,()) <$> newSession shakeExtras shakeDb acts) + (,()) <$> newSession shakeExtras shakeDb acts reason) notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do @@ -643,8 +644,9 @@ newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] + -> String -> IO ShakeSession -newSession extras@ShakeExtras{..} shakeDb acts = do +newSession extras@ShakeExtras{..} shakeDb acts reason = do IdeOptions{optRunSubset} <- getIdeOptionsIO extras reenqueued <- atomically $ peekInProgress actionQueue allPendingKeys <- @@ -673,6 +675,7 @@ newSession extras@ShakeExtras{..} shakeDb acts = do -- The inferred type signature doesn't work in ghc >= 9.0.1 workRun :: (forall b. IO b -> IO b) -> IO (IO ()) workRun restore = withSpan "Shake session" $ \otSpan -> do + setTag otSpan "_reason" (fromString reason) whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $ diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index fca676d8da..4fb1d4fac4 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -83,15 +83,16 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and -- what we do with them - let msg = show fileEvents - logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg -- filter out files of interest, since we already know all about those + -- filter also uris that do not map to filenames, since we cannot handle them filesOfInterest <- getFilesOfInterest ide let fileEvents' = [ f | f@(FileEvent uri _) <- fileEvents , Just fp <- [uriToFilePath uri] , not $ HM.member (toNormalizedFilePath fp) filesOfInterest ] + let msg = show fileEvents' + logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg modifyFileExists ide fileEvents' resetFileStore ide fileEvents' setSomethingModified ide [] msg diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b755969ada..b1d9b8ccbd 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Development.IDE.Main (Arguments(..) +,defaultArguments ,Command(..) ,IdeCommand(..) ,isLSP @@ -22,12 +23,17 @@ 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.Word (Word16) +import Debug.Trace.Flags (userTracingEnabled) import Development.IDE (Action, GhcVersion (..), - Rules, ghcVersion, + Priority (Debug), Rules, + ghcVersion, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) @@ -64,6 +70,7 @@ import Development.IDE.Session (SessionLoadingOptions, import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') import Development.IDE.Types.Logger (Logger (Logger), + Priority (Info), logDebug, logInfo) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), @@ -94,6 +101,7 @@ import Ide.Types (IdeCommand (IdeCommand), ipMap) import qualified Language.LSP.Server as LSP import Numeric.Natural (Natural) +import OpenTelemetry.Eventlog (addEvent, withSpan) import Options.Applicative hiding (action) import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), @@ -175,10 +183,13 @@ data Arguments = Arguments } instance Default Arguments where - def = Arguments + def = defaultArguments Info + +defaultArguments :: Priority -> Arguments +defaultArguments priority = Arguments { argsOTMemoryProfiling = False , argCommand = LSP - , argsLogger = stderrLogger + , argsLogger = stderrLogger priority <> telemetryLogger , argsRules = mainRule >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors @@ -207,7 +218,7 @@ instance Default Arguments where } testing :: Arguments -testing = def { +testing = (defaultArguments Debug) { argsHlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc (argsHlsPlugins def) ++ [Test.blockCommandDescriptor "block-command", Test.plugin], @@ -219,12 +230,22 @@ testing = def { } -- | Cheap stderr logger that relies on LineBuffering -stderrLogger :: IO Logger -stderrLogger = do +stderrLogger :: Priority -> IO Logger +stderrLogger logLevel = do lock <- newLock - return $ Logger $ \p m -> withLock lock $ + return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $ T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m +telemetryLogger :: IO Logger +telemetryLogger + | userTracingEnabled = return $ Logger $ \p m -> + withSpan "log" $ \sp -> + addEvent sp (fromString $ "Log " <> show p) (encodeUtf8 $ trim m) + | otherwise = mempty + 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/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 1213067ffe..05975a59c9 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -33,6 +33,11 @@ data Priority -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} +instance Semigroup Logger where + l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t + +instance Monoid Logger where + mempty = Logger $ \_ _ -> pure () logError :: Logger -> T.Text -> IO () logError x = logPriority x Error diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 7cf6d3b882..44e2c080d6 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -9,8 +9,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -482,7 +484,9 @@ instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTrac instance HasTracing Value instance HasTracing ExecuteCommandParams -instance HasTracing DidChangeWatchedFilesParams +instance HasTracing DidChangeWatchedFilesParams where + traceWithSpan sp DidChangeWatchedFilesParams{_changes} = + setTag sp "changes" (encodeUtf8 $ fromString $ show _changes) instance HasTracing DidChangeWorkspaceFoldersParams instance HasTracing DidChangeConfigurationParams instance HasTracing InitializeParams