Refactor LSP logger to pass environment via an MVar

Also adds a logger that forwards on messages via `window/logMessage`.
haskell · Mar 6, 2022 · 5b61944 · 5b61944
1 parent e29f61f
commit 5b61944
Show file tree

Hide file tree

Showing 9 changed files with 150 additions and 116 deletions.
diff --git a/exe/Main.hs b/exe/Main.hs
@@ -4,9 +4,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main(main) where
 
+import           Control.Concurrent           (newEmptyMVar)
 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,
@@ -36,7 +37,10 @@ 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
+
+    lspEnvVar <- newEmptyMVar
+    lspLogRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientLogRecorder
+    lspMessageRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientMessageRecorder
 
     let (minPriority, logFilePath, includeExamplePlugins) =
           case args of
@@ -50,13 +54,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 renderDoc
             ]
-        plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins
 
-      defaultMain (cmapWithPrio LogIdeMain recorder) args (pluginDescToIdePlugins [lspRecorderPlugin] <> plugins)
+      defaultMain
+        (cmapWithPrio LogIdeMain recorder)
+        (Just lspEnvVar)
+        args
+        (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)
 
 renderDoc :: Doc a -> Text
 renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep

diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs
@@ -7,6 +7,7 @@ module Main(main) where
 
 import           Arguments                         (Arguments (..),
                                                     getArguments)
+import           Control.Concurrent (newEmptyMVar)
 import           Control.Monad.Extra               (unless)
 import           Data.Default                      (def)
 import           Data.Function                     ((&))
@@ -27,7 +28,7 @@ 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)
@@ -39,8 +40,6 @@ 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
@@ -88,13 +87,16 @@ main = withTelemetryLogger $ \telemetryLogger -> do
 
     docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
 
-    (lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder
+    lspEnvVar <- newEmptyMVar
+    lspLogRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientLogRecorder
+    lspMessageRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientMessageRecorder
 
     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))
@@ -107,11 +109,10 @@ main = withTelemetryLogger $ \telemetryLogger -> do
           then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger
           else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger
 
-    IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
+    IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (Just lspEnvVar) arguments
         { IDEMain.argsProjectRoot = Just argsCwd
         , IDEMain.argCommand = argsCommand
         , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger
-        , IDEMain.argsHlsPlugins = pluginDescToIdePlugins [lspRecorderPlugin] <> IDEMain.argsHlsPlugins arguments
 
         , IDEMain.argsRules = do
             -- install the main and ghcide-plugin rules

diff --git a/ghcide/ghcide.cabal b/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

diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs
@@ -11,6 +11,7 @@ module Development.IDE.Main
 ,testing
 ,Log(..)
 ) where
+import           Control.Concurrent                    (MVar, putMVar)
 import           Control.Concurrent.Extra              (withNumCapabilities)
 import           Control.Concurrent.STM.Stats          (atomically,
                                                         dumpSTMStats)
@@ -20,7 +21,7 @@ import           Control.Monad.Extra                   (concatMapM, unless,
                                                         when)
 import qualified Data.Aeson.Encode.Pretty              as A
 import           Data.Default                          (Default (def))
-import           Data.Foldable                         (traverse_)
+import           Data.Foldable                         (traverse_, for_)
 import qualified Data.HashMap.Strict                   as HashMap
 import           Data.Hashable                         (hashed)
 import           Data.List.Extra                       (intercalate, isPrefixOf,
@@ -233,7 +234,6 @@ data Arguments = Arguments
     , argsThreads               :: Maybe Natural
     }
 
-
 defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments
 defaultArguments recorder logger = Arguments
         { argsProjectRoot = Nothing
@@ -289,9 +289,14 @@ testing recorder logger =
       , argsIdeOptions = ideOptions
       }
 
-
-defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
-defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
+defaultMain
+    :: Recorder (WithPriority Log)
+    -> Maybe (MVar (LSP.LanguageContextEnv Config))
+    -- ^ Variable to be filled with the LSP environment, useful for tools that need this outside
+    -- the scope of runLanguageServer
+    -> Arguments
+    -> IO ()
+defaultMain recorder lspEnvVar Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
  where
   log :: Priority -> Log -> IO ()
   log = logWith recorder
@@ -329,6 +334,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                 t <- t
                 log Info $ LogLspStartDuration t
 
+                for_ lspEnvVar $ \var -> putMVar var env
+
                 dir <- maybe IO.getCurrentDirectory return rootPath
 
                 -- We want to set the global DynFlags right now, so that we can use

diff --git a/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs b/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs
diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs
@@ -21,38 +21,51 @@ 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            (MVar, myThreadId, tryReadMVar)
+import           Control.Concurrent.Extra      (Lock, newLock, withLock)
+import           Control.Concurrent.STM        (atomically, newTQueueIO,
+                                                writeTQueue)
+import           Control.Concurrent.STM.TQueue (flushTQueue)
+import           Control.Exception             (IOException)
+import           Control.Monad                 (forM_, when, (>=>))
+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 +217,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 +303,50 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d
           pure (threadIdToText threadId)
         PriorityColumn -> pure (priorityToText priority)
         DataColumn -> pure payload
+
+-- | Given a 'Recorder' that requires an argument, and an 'MVar' that
+-- will eventually be filled with that argument, produces a 'Recorder'
+-- that queues up messages until the argument is available, at which
+-- point it sends the backlog.
+withBacklog :: MVar v -> (v -> Recorder a) -> IO (Recorder a)
+withBacklog argVar recFun = do
+  backlog <- newTQueueIO
+  pure $ Recorder $ \it -> do
+        marg <- liftIO $ tryReadMVar argVar
+        case marg of
+          Nothing -> liftIO $ atomically $ writeTQueue backlog it
+          Just arg -> do
+              let recorder = recFun arg
+              toRecord <- liftIO $ atomically $ flushTQueue backlog
+              for_ toRecord (logger_ recorder)
+              logger_ recorder it
+
+-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.
+lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
+lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->
+  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 {..} ->
+  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
diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -6407,7 +6407,7 @@ testIde recorder arguments session = do
     (hInRead, hInWrite) <- createPipe
     (hOutRead, hOutWrite) <- createPipe
     let projDir = "."
-    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
+    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) Nothing arguments
             { IDE.argsHandleIn = pure hInRead
             , IDE.argsHandleOut = pure hOutWrite
             }

diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs
@@ -219,6 +219,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre
     async $
       Ghcide.defaultMain
         (cmapWithPrio LogIDEMain recorder)
+        Nothing
         arguments
           { argsHandleIn = pure inR
           , argsHandleOut = pure outW