diff --git a/exe/Main.hs b/exe/Main.hs index ef5fdacbed..f6076311aa 100644 --- a/exe/Main.hs +++ b/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 diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index de5f5f22b8..d20bf4f0cf 100644 --- a/ghcide/exe/Main.hs +++ b/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 diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 169bc19a84..b34170e68c 100644 --- 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/Plugin/LSPWindowShowMessageRecorder.hs b/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs deleted file mode 100644 index 213c5849d0..0000000000 --- a/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder) where - -import Control.Monad.IO.Class -import Data.Foldable (for_) -import Data.IORef -import Data.IORef.Extra (atomicModifyIORef'_) -import Data.Text (Text) -import Development.IDE.Types.Logger -import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) -import Language.LSP.Server (LanguageContextEnv, getLspEnv) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (MessageType (..), SMethod (SInitialized, SWindowShowMessage), ShowMessageParams (..)) - --- | Creates a recorder that logs to the LSP stream via WindowShowMessage notifications. --- The recorder won't attempt to send messages until the LSP stream is initialized. -makeLspShowMessageRecorder :: - IO (Recorder (WithPriority Text), PluginDescriptor c) -makeLspShowMessageRecorder = do - envRef <- newIORef Nothing - -- messages logged before the LSP stream is initialized will be sent when it is - backLogRef <- newIORef [] - let recorder = Recorder $ \it -> do - mbenv <- liftIO $ readIORef envRef - liftIO $ case mbenv of - Nothing -> atomicModifyIORef'_ backLogRef (it :) - Just env -> sendMsg env it - -- the plugin captures the language context, so it can be used to send messages - plugin = - (defaultPluginDescriptor "LSPWindowShowMessageRecorder") - { pluginNotificationHandlers = mkPluginNotificationHandler SInitialized $ \_ _ _ -> do - env <- getLspEnv - liftIO $ writeIORef envRef $ Just env - -- flush the backlog - backLog <- liftIO $ atomicModifyIORef' backLogRef ([],) - liftIO $ for_ (reverse backLog) $ sendMsg env - } - return (recorder, plugin) - -sendMsg :: LanguageContextEnv config -> WithPriority Text -> IO () -sendMsg env WithPriority {..} = - LSP.runLspT env $ - LSP.sendNotification - SWindowShowMessage - ShowMessageParams - { _xtype = priorityToLsp priority, - _message = payload - } - -priorityToLsp :: Priority -> MessageType -priorityToLsp = - \case - Debug -> MtLog - Info -> MtInfo - Warning -> MtWarning - Error -> MtError diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 35582cdccd..c57dc0f52c 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/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 diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index ff709441fa..91cb322e20 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/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 #-}"