Refactor LSP logger and log via window/logMessage also

exe/Main.hs

@@ -4,9 +4,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main(main) where
 
+import           Control.Monad.IO.Class       (liftIO)
 import           Data.Function                ((&))
 import           Data.Text (Text)
-import           Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder)
+import qualified Development.IDE.Types.Logger as Logger
 import           Development.IDE.Types.Logger (Priority (Debug, Info, Error),
                                                WithPriority (WithPriority, priority),
                                                cfilter, cmapWithPrio,
@@ -17,7 +18,10 @@ import           Ide.Arguments                (Arguments (..),
                                                getArguments)
 import           Ide.Main                     (defaultMain)
 import qualified Ide.Main                     as IdeMain
-import           Ide.PluginUtils (pluginDescToIdePlugins)
+import           Ide.PluginUtils              (pluginDescToIdePlugins)
+import           Ide.Types                    (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler)
+import           Language.LSP.Server          as LSP
+import           Language.LSP.Types           as LSP
 import qualified Plugins
 import           Prettyprinter                (Pretty (pretty), vsep)
 
@@ -36,7 +40,16 @@ main = do
     -- parser to get logging arguments first or do more complicated things
     pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info
     args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False)
-    (lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder
+
+    (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
+    (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
+    -- This plugin just installs a handler for the `initialized` notification, which then
+    -- picks up the LSP environment and feeds it to our recorders
+    let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")
+          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ -> do
+              env <- LSP.getLspEnv
+              liftIO $ (cb1 <> cb2) env
+          }
 
     let (minPriority, logFilePath, includeExamplePlugins) =
           case args of
@@ -50,13 +63,19 @@ main = do
         recorder = cmapWithPrio pretty $ mconcat
             [textWithPriorityRecorder
                 & cfilter (\WithPriority{ priority } -> priority >= minPriority)
-            , lspRecorder
+            , lspMessageRecorder
                 & cfilter (\WithPriority{ priority } -> priority >= Error)
                 & cmapWithPrio renderDoc
+            , lspLogRecorder
+                & cfilter (\WithPriority{ priority } -> priority >= minPriority)
+                & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
             ]
-        plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins
+        plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)
 
-      defaultMain (cmapWithPrio LogIdeMain recorder) args (pluginDescToIdePlugins [lspRecorderPlugin] <> plugins)
+      defaultMain
+        (cmapWithPrio LogIdeMain recorder)
+        args
+        (plugins <> pluginDescToIdePlugins [lspRecorderPlugin])
 
 renderDoc :: Doc a -> Text
 renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep

ghcide/exe/Main.hs

@@ -8,6 +8,7 @@ module Main(main) where
 import           Arguments                         (Arguments (..),
                                                     getArguments)
 import           Control.Monad.Extra               (unless)
+import           Control.Monad.IO.Class            (liftIO)
 import           Data.Default                      (def)
 import           Data.Function                     ((&))
 import           Data.Version                      (showVersion)
@@ -26,20 +27,21 @@ import           Development.IDE.Types.Logger      (Logger (Logger),
                                                     Recorder (Recorder),
                                                     WithPriority (WithPriority, priority),
                                                     cfilter, cmapWithPrio,
-                                                    makeDefaultStderrRecorder, layoutPretty, renderStrict, payload, defaultLayoutOptions)
+                                                    makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions)
 import qualified Development.IDE.Types.Logger      as Logger
 import           Development.IDE.Types.Options
 import           GHC.Stack                         (emptyCallStack)
+import           Language.LSP.Server               as LSP
+import           Language.LSP.Types                as LSP
 import           Ide.Plugin.Config                 (Config (checkParents, checkProject))
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
+import           Ide.Types                         (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler)
 import           Paths_ghcide                      (version)
 import qualified System.Directory.Extra            as IO
 import           System.Environment                (getExecutablePath)
 import           System.Exit                       (exitSuccess)
 import           System.IO                         (hPutStrLn, stderr)
 import           System.Info                       (compilerVersion)
-import Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder)
-import Control.Lens (Contravariant(contramap))
 
 data Log
   = LogIDEMain IDEMain.Log
@@ -87,13 +89,22 @@ main = withTelemetryLogger $ \telemetryLogger -> do
 
     docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
 
-    (lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder
+    (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
+    (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
+    -- This plugin just installs a handler for the `initialized` notification, which then
+    -- picks up the LSP environment and feeds it to our recorders
+    let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")
+          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ -> do
+              env <- LSP.getLspEnv
+              liftIO $ (cb1 <> cb2) env
+          }
 
     let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
           (docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>
-          (lspRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)
-                       & cfilter (\WithPriority{ priority } -> priority >= Error)
-          )
+          (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_ (WithPriority p emptyCallStack (pretty m))
@@ -110,7 +121,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do
         { IDEMain.argsProjectRoot = Just argsCwd
         , IDEMain.argCommand = argsCommand
         , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger
-        , IDEMain.argsHlsPlugins = pluginDescToIdePlugins [lspRecorderPlugin] <> IDEMain.argsHlsPlugins arguments
+        , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]
 
         , IDEMain.argsRules = do
             -- install the main and ghcide-plugin rules

ghcide/ghcide.cabal

@@ -202,7 +202,6 @@ library
         Development.IDE.Plugin.Completions.Types
         Development.IDE.Plugin.CodeAction
         Development.IDE.Plugin.CodeAction.ExactPrint
-        Development.IDE.Plugin.LSPWindowShowMessageRecorder
         Development.IDE.Plugin.HLS
         Development.IDE.Plugin.HLS.GhcIde
         Development.IDE.Plugin.Test

ghcide/src/Development/IDE/Types/Logger.hs

@@ -21,38 +21,50 @@ module Development.IDE.Types.Logger
   , priorityToHsLoggerPriority
   , LoggingColumn(..)
   , cmapWithPrio
+  , withBacklog
+  , lspClientMessageRecorder
+  , lspClientLogRecorder
   , module PrettyPrinterModule
   , renderStrict
   ) where
 
-import           Control.Concurrent         (myThreadId)
-import           Control.Concurrent.Extra   (Lock, newLock, withLock)
-import           Control.Exception          (IOException)
-import           Control.Monad              (forM_, when, (>=>))
-import           Control.Monad.IO.Class     (MonadIO (liftIO))
-import           Data.Functor.Contravariant (Contravariant (contramap))
-import           Data.Maybe                 (fromMaybe)
-import           Data.Text                  (Text)
-import qualified Data.Text                  as T
-import qualified Data.Text                  as Text
-import qualified Data.Text.IO               as Text
-import           Data.Time                  (defaultTimeLocale, formatTime,
-                                             getCurrentTime)
-import           GHC.Stack                  (CallStack, HasCallStack,
-                                             SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),
-                                             callStack, getCallStack,
-                                             withFrozenCallStack)
-import           Prettyprinter              as PrettyPrinterModule
-import           Prettyprinter.Render.Text  (renderStrict)
-import           System.IO                  (Handle, IOMode (AppendMode),
-                                             hClose, hFlush, hSetEncoding,
-                                             openFile, stderr, utf8)
-import qualified System.Log.Formatter       as HSL
-import qualified System.Log.Handler         as HSL
-import qualified System.Log.Handler.Simple  as HSL
-import qualified System.Log.Logger          as HsLogger
-import           UnliftIO                   (MonadUnliftIO, displayException,
-                                             finally, try)
+import           Control.Concurrent            (myThreadId)
+import           Control.Concurrent.Extra      (Lock, newLock, withLock)
+import           Control.Concurrent.STM        (atomically,
+                                                newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue)
+import           Control.Exception             (IOException)
+import           Control.Monad                 (forM_, when, (>=>), unless)
+import           Control.Monad.IO.Class        (MonadIO (liftIO))
+import           Data.Foldable                 (for_)
+import           Data.Functor.Contravariant    (Contravariant (contramap))
+import           Data.Maybe                    (fromMaybe)
+import           Data.Text                     (Text)
+import qualified Data.Text                     as T
+import qualified Data.Text                     as Text
+import qualified Data.Text.IO                  as Text
+import           Data.Time                     (defaultTimeLocale, formatTime,
+                                                getCurrentTime)
+import           GHC.Stack                     (CallStack, HasCallStack,
+                                                SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),
+                                                callStack, getCallStack,
+                                                withFrozenCallStack)
+import           Language.LSP.Server
+import qualified Language.LSP.Server           as LSP
+import           Language.LSP.Types            (LogMessageParams (..),
+                                                MessageType (..),
+                                                SMethod (SWindowLogMessage, SWindowShowMessage),
+                                                ShowMessageParams (..))
+import           Prettyprinter                 as PrettyPrinterModule
+import           Prettyprinter.Render.Text     (renderStrict)
+import           System.IO                     (Handle, IOMode (AppendMode),
+                                                hClose, hFlush, hSetEncoding,
+                                                openFile, stderr, utf8)
+import qualified System.Log.Formatter          as HSL
+import qualified System.Log.Handler            as HSL
+import qualified System.Log.Handler.Simple     as HSL
+import qualified System.Log.Logger             as HsLogger
+import           UnliftIO                      (MonadUnliftIO, displayException,
+                                                finally, try)
 
 data Priority
 -- Don't change the ordering of this type or you will mess up the Ord
@@ -204,10 +216,10 @@ makeDefaultHandleRecorder columns minPriority lock handle = do
 
 priorityToHsLoggerPriority :: Priority -> HsLogger.Priority
 priorityToHsLoggerPriority = \case
-  Debug     -> HsLogger.DEBUG
-  Info      -> HsLogger.INFO
-  Warning   -> HsLogger.WARNING
-  Error     -> HsLogger.ERROR
+  Debug   -> HsLogger.DEBUG
+  Info    -> HsLogger.INFO
+  Warning -> HsLogger.WARNING
+  Error   -> HsLogger.ERROR
 
 -- | The purpose of setting up `hslogger` at all is that `hie-bios` uses
 -- `hslogger` to output compilation logs. The easiest way to merge these logs
@@ -290,3 +302,61 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d
           pure (threadIdToText threadId)
         PriorityColumn -> pure (priorityToText priority)
         DataColumn -> pure payload
+
+-- | Given a 'Recorder' that requires an argument, produces a 'Recorder'
+-- that queues up messages until the argument is provided using the callback, at which
+-- point it sends the backlog and begins functioning normally.
+withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())
+withBacklog recFun = do
+  -- Arbitrary backlog capacity
+  backlog <- newTBQueueIO 100
+  let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do
+          -- If the queue is full just drop the message on the floor. This is most likely
+          -- to happen if the callback is just never going to be called; in which case
+          -- we want neither to build up an unbounded backlog in memory, nor block waiting
+          -- for space!
+          full <- isFullTBQueue backlog
+          unless full $ writeTBQueue backlog it
+
+  -- The variable holding the recorder starts out holding the recorder that writes
+  -- to the backlog.
+  recVar <- newTVarIO backlogRecorder
+  -- The callback atomically swaps out the recorder for the final one, and flushes
+  -- the backlog to it.
+  let cb arg = do
+        let recorder = recFun arg
+        toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog
+        for_ toRecord (logger_ recorder)
+
+  -- The recorder we actually return looks in the variable and uses whatever is there.
+  let varRecorder = Recorder $ \it -> do
+          r <- liftIO $ readTVarIO recVar
+          logger_ r it
+
+  pure (varRecorder, cb)
+
+-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.
+lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
+lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->
+  liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage
+      ShowMessageParams
+        { _xtype = priorityToLsp priority,
+          _message = payload
+        }
+
+-- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.
+lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
+lspClientLogRecorder env = Recorder $ \WithPriority {..} ->
+  liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage
+      LogMessageParams
+        { _xtype = priorityToLsp priority,
+          _message = payload
+        }
+
+priorityToLsp :: Priority -> MessageType
+priorityToLsp =
+  \case
+    Debug   -> MtLog
+    Info    -> MtInfo
+    Warning -> MtWarning
+    Error   -> MtError

test/functional/FunctionalCodeAction.hs

@@ -43,7 +43,7 @@ renameTests = testGroup "rename suggestions" [
         cars <- getAllCodeActions doc
         replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"]
         executeCommand replaceButStrLn
-        _ <- anyRequest
+        _ <- skipManyTill loggingNotification anyRequest
 
         x:_ <- T.lines <$> documentContents doc
         liftIO $ x @?= "main = putStrLn \"hello\""
@@ -65,7 +65,7 @@ renameTests = testGroup "rename suggestions" [
                 _ -> error $ "Unexpected arguments: " ++ show mbArgs
 
             executeCommand cmd
-            _ <- anyRequest
+            _ <- skipManyTill loggingNotification anyRequest
 
             x1:x2:_ <- T.lines <$> documentContents doc
             liftIO $
@@ -207,7 +207,7 @@ redundantImportTests = testGroup "redundant import code actions" [
         cas <- getAllCodeActions doc
         cmd <- liftIO $ inspectCommand cas ["redundant import"]
         executeCommand cmd
-        _ <- anyRequest
+        _ <- skipManyTill loggingNotification anyRequest
         contents <- documentContents doc
         liftIO $ T.lines contents @?=
                 [ "{-# OPTIONS_GHC -Wunused-imports #-}"