Trace log events and fix ghcide logger

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

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) $

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 $

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

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

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

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