From a8bf3b333e90dc055a7a7b73418025a7183fbcd9 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 12:47:42 +0100 Subject: [PATCH 1/8] Monoid instance for Logger --- ghcide/src/Development/IDE/Types/Logger.hs | 5 +++++ 1 file changed, 5 insertions(+) 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 From 693a09580d3031142d5dc8059e3f33bf7b33a499 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 12:54:41 +0100 Subject: [PATCH 2/8] trace log events --- ghcide/src/Development/IDE/Main.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b755969ada..615a4c2ac0 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -22,10 +22,14 @@ 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, hDuplicateTo') @@ -94,6 +98,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), @@ -178,7 +183,7 @@ instance Default Arguments where def = Arguments { argsOTMemoryProfiling = False , argCommand = LSP - , argsLogger = stderrLogger + , argsLogger = stderrLogger <> telemetryLogger , argsRules = mainRule >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors @@ -225,6 +230,16 @@ stderrLogger = do return $ Logger $ \p m -> 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 From 2881aa43268415e9e2b6a3f738cbc0482859679a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 12 Oct 2021 20:56:11 +0100 Subject: [PATCH 3/8] fix chatty ghcide logger --- ghcide/exe/Main.hs | 7 ++++--- ghcide/src/Development/IDE/Main.hs | 20 +++++++++++++------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 0698fbe98d..da220896ed 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -8,10 +8,10 @@ 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)) @@ -51,7 +51,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/Main.hs b/ghcide/src/Development/IDE/Main.hs index 615a4c2ac0..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 @@ -31,7 +32,8 @@ 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) @@ -68,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), @@ -180,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 <> telemetryLogger + , argsLogger = stderrLogger priority <> telemetryLogger , argsRules = mainRule >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors @@ -212,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], @@ -224,10 +230,10 @@ 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 From 7e2e077d8d2ff0df5a581d9d22716bcd041dd0a3 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 21:21:48 +0100 Subject: [PATCH 4/8] fix debugging printout --- ghcide/src/Development/IDE/Core/OfInterest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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) $ From a76f8acd7a05cca61d366aac599aaab1791febd7 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 12:48:45 +0100 Subject: [PATCH 5/8] trace build reason --- ghcide/src/Development/IDE/Core/Shake.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) 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 $ From cf64ad23c44f3de0ef24119719727d219dcf11cb Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 9 Oct 2021 00:07:07 +0100 Subject: [PATCH 6/8] redundant import --- ghcide/exe/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index da220896ed..587b18f8ca 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -17,7 +17,6 @@ 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) From a94a5ae7c43b62f3983180e52a39313e581384fa Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 11:00:00 +0100 Subject: [PATCH 7/8] trace WatchedFile _changes --- hls-plugin-api/src/Ide/Types.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) 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 From 7fd2465cc87a0405077b28707802ab02667771f3 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 11:00:20 +0100 Subject: [PATCH 8/8] log filtered file events --- ghcide/src/Development/IDE/LSP/Notifications.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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