Merge branch 'master' into 4173-extracts-ghcide-tests-and-migrate-it-…

…to-use-hls-test-utils

exe/Wrapper.hs

@@ -41,11 +41,8 @@ import qualified Data.Text                          as T
 import qualified Data.Text.IO                       as T
 import           Development.IDE.LSP.LanguageServer (runLanguageServer)
 import qualified Development.IDE.Main               as Main
-import           GHC.Stack.Types                    (emptyCallStack)
-import           Ide.Logger                         (Doc, Logger (Logger),
-                                                     Pretty (pretty),
-                                                     Recorder (logger_),
-                                                     WithPriority (WithPriority),
+import           Ide.Logger                         (Doc, Pretty (pretty),
+                                                     Recorder, WithPriority,
                                                      cmapWithPrio,
                                                      makeDefaultStderrRecorder)
 import           Ide.Plugin.Config                  (Config)
@@ -272,9 +269,7 @@ newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a }
 -- to shut down the LSP.
 launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO ()
 launchErrorLSP recorder errorMsg = do
-  let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack (pretty m))
-
-  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) logger (IdePlugins [])
+  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins [])
 
   inH <- Main.argsHandleIn defaultArguments
 

ghcide/exe/Main.hs

@@ -16,14 +16,12 @@ import           Development.IDE                          (action)
 import           Development.IDE.Core.OfInterest          (kick)
 import           Development.IDE.Core.Rules               (mainRule)
 import qualified Development.IDE.Core.Rules               as Rules
-import           Development.IDE.Core.Tracing             (withTelemetryLogger)
+import           Development.IDE.Core.Tracing             (withTelemetryRecorder)
 import qualified Development.IDE.Main                     as IDEMain
 import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry
 import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde
 import           Development.IDE.Types.Options
-import           GHC.Stack                                (emptyCallStack)
-import           Ide.Logger                               (Logger (Logger),
-                                                           LoggingColumn (DataColumn, PriorityColumn),
+import           Ide.Logger                               (LoggingColumn (DataColumn, PriorityColumn),
                                                            Pretty (pretty),
                                                            Priority (Debug, Error, Info),
                                                            WithPriority (WithPriority, priority),
@@ -71,7 +69,7 @@ ghcideVersion = do
              <> gitHashSection
 
 main :: IO ()
-main = withTelemetryLogger $ \telemetryLogger -> do
+main = withTelemetryRecorder $ \telemetryRecorder -> do
     -- stderr recorder just for plugin cli commands
     pluginCliRecorder <-
       cmapWithPrio pretty
@@ -109,23 +107,20 @@ main = withTelemetryLogger $ \telemetryLogger -> do
           (lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
                           & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>
           (lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
-                              & cfilter (\WithPriority{ priority } -> priority >= Error))
-
-    -- exists so old-style logging works. intended to be phased out
-    let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m))
+                              & cfilter (\WithPriority{ priority } -> priority >= Error)) <>
+          telemetryRecorder
 
     let recorder = docWithFilteredPriorityRecorder
                  & cmapWithPrio pretty
 
     let arguments =
           if argsTesting
-          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins
-          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins
+          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) hlsPlugins
+          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsPlugins
 
     IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
         { IDEMain.argsProjectRoot = Just argsCwd
         , IDEMain.argCommand = argsCommand
-        , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger
         , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]
 
         , IDEMain.argsRules = do

ghcide/src/Development/IDE/Core/OfInterest.hs

@@ -42,10 +42,11 @@ import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options            (IdeTesting (..))
 import           GHC.TypeLits                             (KnownSymbol)
 import           Ide.Logger                               (Pretty (pretty),
+                                                           Priority (..),
                                                            Recorder,
                                                            WithPriority,
                                                            cmapWithPrio,
-                                                           logDebug)
+                                                           logWith)
 import qualified Language.LSP.Protocol.Message            as LSP
 import qualified Language.LSP.Server                      as LSP
 
@@ -110,16 +111,16 @@ addFileOfInterest state f v = do
         pure (new, (prev, new))
     when (prev /= Just v) $ do
         join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
-        logDebug (ideLogger state) $
-            "Set files of interest to: " <> T.pack (show files)
+        logWith (ideLogger state) Debug $
+            LogSetFilesOfInterest (HashMap.toList files)
 
 deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
 deleteFileOfInterest state f = do
     OfInterestVar var <- getIdeGlobalState state
     files <- modifyVar' var $ HashMap.delete f
     join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
-
+    logWith (ideLogger state) Debug $
+        LogSetFilesOfInterest (HashMap.toList files)
 scheduleGarbageCollection :: IdeState -> IO ()
 scheduleGarbageCollection state = do
     GarbageCollectVar var <- getIdeGlobalState state

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -41,6 +41,8 @@ import           Development.IDE.Spans.Common
 import           Development.IDE.Spans.LocalBindings
 import           Development.IDE.Types.Diagnostics
 import           GHC.Serialized                               (Serialized)
+import           Ide.Logger                                   (Pretty (..),
+                                                               viaShow)
 import           Language.LSP.Protocol.Types                  (Int32,
                                                                NormalizedFilePath)
 
@@ -340,6 +342,9 @@ data FileOfInterestStatus
 instance Hashable FileOfInterestStatus
 instance NFData   FileOfInterestStatus
 
+instance Pretty FileOfInterestStatus where
+    pretty = viaShow
+
 data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus
   deriving (Eq, Show, Typeable, Generic)
 instance Hashable IsFileOfInterestResult

ghcide/src/Development/IDE/Core/Service.hs

@@ -22,8 +22,7 @@ import           Development.IDE.Core.FileExists  (fileExistsRules)
 import           Development.IDE.Core.OfInterest  hiding (Log, LogShake)
 import           Development.IDE.Graph
 import           Development.IDE.Types.Options    (IdeOptions (..))
-import           Ide.Logger                       as Logger (Logger,
-                                                             Pretty (pretty),
+import           Ide.Logger                       as Logger (Pretty (pretty),
                                                              Priority (Debug),
                                                              Recorder,
                                                              WithPriority,
@@ -63,14 +62,13 @@ initialise :: Recorder (WithPriority Log)
            -> IdePlugins IdeState
            -> Rules ()
            -> Maybe (LSP.LanguageContextEnv Config)
-           -> Logger
            -> Debouncer LSP.NormalizedUri
            -> IdeOptions
            -> WithHieDb
            -> IndexQueue
            -> Monitoring
            -> IO IdeState
-initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do
+initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do
     shakeProfiling <- do
         let fromConf = optShakeProfiling options
         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
@@ -80,7 +78,6 @@ initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer optio
         lspEnv
         defaultConfig
         plugins
-        logger
         debouncer
         shakeProfiling
         (optReportProgress options)

ghcide/src/Development/IDE/Core/Shake.hs

@@ -168,11 +168,11 @@ import qualified Language.LSP.Server                    as LSP
 import           Language.LSP.VFS                       hiding (start)
 import qualified "list-t" ListT
 import           OpenTelemetry.Eventlog                 hiding (addEvent)
+import qualified Prettyprinter                          as Pretty
 import qualified StmContainers.Map                      as STM
 import           System.FilePath                        hiding (makeRelative)
 import           System.IO.Unsafe                       (unsafePerformIO)
 import           System.Time.Extra
-
 -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
 
 #if !MIN_VERSION_ghc(9,3,0)
@@ -191,6 +191,12 @@ data Log
   | LogDiagsDiffButNoLspEnv ![FileDiagnostic]
   | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic
   | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic
+  | LogCancelledAction !T.Text
+  | LogSessionInitialised
+  | LogLookupPersistentKey !T.Text
+  | LogShakeGarbageCollection !T.Text !Int !Seconds
+  -- * OfInterest Log messages
+  | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
   deriving Show
 
 instance Pretty Log where
@@ -224,6 +230,16 @@ instance Pretty Log where
     LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic ->
       "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:"
       <+> pretty (showDiagnosticsColored [fileDiagnostic])
+    LogCancelledAction action ->
+        pretty action <+> "was cancelled"
+    LogSessionInitialised -> "Shake session initialized"
+    LogLookupPersistentKey key ->
+        "LOOKUP PERSISTENT FOR:" <+> pretty key
+    LogShakeGarbageCollection label number duration ->
+        pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")"
+    LogSetFilesOfInterest ofInterest ->
+        "Set files of interst to" <> Pretty.line
+            <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)
 
 -- | We need to serialize writes to the database, so we send any function that
 -- needs to write to the database over the channel, where it will be picked up by
@@ -254,7 +270,7 @@ data ShakeExtras = ShakeExtras
     { --eventer :: LSP.FromServerMessage -> IO ()
      lspEnv :: Maybe (LSP.LanguageContextEnv Config)
     ,debouncer :: Debouncer NormalizedUri
-    ,logger :: Logger
+    ,shakeRecorder :: Recorder (WithPriority Log)
     ,idePlugins :: IdePlugins IdeState
     ,globals :: TVar (HMap.HashMap TypeRep Dynamic)
       -- ^ Registry of global state used by rules.
@@ -439,7 +455,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
           | otherwise = do
           pmap <- readTVarIO persistentKeys
           mv <- runMaybeT $ do
-            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
+            liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k)
             f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap
             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
@@ -602,7 +618,6 @@ shakeOpen :: Recorder (WithPriority Log)
           -> Maybe (LSP.LanguageContextEnv Config)
           -> Config
           -> IdePlugins IdeState
-          -> Logger
           -> Debouncer NormalizedUri
           -> Maybe FilePath
           -> IdeReportProgress
@@ -613,7 +628,7 @@ shakeOpen :: Recorder (WithPriority Log)
           -> Monitoring
           -> Rules ()
           -> IO IdeState
-shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
+shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
   shakeProfileDir (IdeReportProgress reportProgress)
   ideTesting@(IdeTesting testing)
   withHieDb indexQueue opts monitoring rules = mdo
@@ -660,7 +675,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
         dirtyKeys <- newTVarIO mempty
         -- Take one VFS snapshot at the start
         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
-        pure ShakeExtras{..}
+        pure ShakeExtras{shakeRecorder = recorder, ..}
     shakeDb  <-
         shakeNewDatabase
             opts { shakeExtra = newShakeExtra shakeExtras }
@@ -707,7 +722,7 @@ shakeSessionInit recorder ide@IdeState{..} = do
     vfs <- vfsSnapshot (lspEnv shakeExtras)
     initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"
     putMVar shakeSession initSession
-    logDebug (ideLogger ide) "Shake session initialized"
+    logWith recorder Debug LogSessionInitialised
 
 shakeShut :: IdeState -> IO ()
 shakeShut IdeState{..} = do
@@ -775,7 +790,7 @@ shakeRestart recorder IdeState{..} vfs reason acts =
 --
 --   Appropriate for user actions other than edits.
 shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
-shakeEnqueue ShakeExtras{actionQueue, logger} act = do
+shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
     (b, dai) <- instantiateDelayedAction act
     atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue
     let wait' barrier =
@@ -784,7 +799,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do
                     fail $ "internal bug: forever blocked on MVar for " <>
                             actionName act)
               , Handler (\e@AsyncCancelled -> do
-                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
+                  logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)
 
                   atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue
                   throw e)
@@ -908,13 +923,12 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection
 garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
 garbageCollectKeys label maxAge checkParents agedKeys = do
     start <- liftIO offsetTime
-    ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras
+    ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
     (n::Int, garbage) <- liftIO $
         foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys
     t <- liftIO start
     when (n>0) $ liftIO $ do
-        logDebug logger $ T.pack $
-            label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
+        logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t
     when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $
         LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))
                              (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)
@@ -1305,13 +1319,11 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
             | otherwise = c
 
 
-ideLogger :: IdeState -> Logger
-ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
+ideLogger :: IdeState -> Recorder (WithPriority Log)
+ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder
 
-actionLogger :: Action Logger
-actionLogger = do
-    ShakeExtras{logger} <- getShakeExtras
-    return logger
+actionLogger :: Action (Recorder (WithPriority Log))
+actionLogger = shakeRecorder <$> getShakeExtras
 
 --------------------------------------------------------------------------------
 type STMDiagnosticStore = STM.Map NormalizedUri StoreItem

ghcide/src/Development/IDE/Core/Tracing.hs

@@ -7,7 +7,7 @@ module Development.IDE.Core.Tracing
     , otTracedGarbageCollection
     , withTrace
     , withEventTrace
-    , withTelemetryLogger
+    , withTelemetryRecorder
     )
 where
 
@@ -26,7 +26,7 @@ import           Development.IDE.Graph.Rule
 import           Development.IDE.Types.Diagnostics (FileDiagnostic,
                                                     showDiagnostics)
 import           Development.IDE.Types.Location    (Uri (..))
-import           Ide.Logger                        (Logger (Logger))
+import           Ide.Logger
 import           Ide.Types                         (PluginId (..))
 import           Language.LSP.Protocol.Types       (NormalizedFilePath,
                                                     fromNormalizedFilePath)
@@ -51,16 +51,20 @@ withEventTrace name act
   | 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 ->
+withTelemetryRecorder :: (MonadIO m, MonadMask m) => (Recorder (WithPriority (Doc a)) -> m c) -> m c
+withTelemetryRecorder 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)
+    k $ telemetryLogRecorder sp
+
+-- | Returns a logger that produces telemetry events in a single span.
+telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a))
+telemetryLogRecorder sp = Recorder $ \WithPriority {..} ->
+  liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact $ payload)
+  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