diff --git a/exe/Main.hs b/exe/Main.hs index 098a427ef9..083f76a1b4 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -5,9 +5,11 @@ {-# LANGUAGE OverloadedStrings #-} module Main(main) where +import Control.Arrow ((&&&)) import Control.Monad.IO.Class (liftIO) import Data.Function ((&)) import Data.Text (Text) +import qualified Development.IDE.Main as GhcideMain import Development.IDE.Types.Logger (Doc, Priority (Debug, Error, Info), WithPriority (WithPriority, priority), @@ -15,7 +17,7 @@ import Development.IDE.Types.Logger (Doc, defaultLayoutOptions, layoutPretty, makeDefaultStderrRecorder, - renderStrict, + payload, renderStrict, withDefaultRecorder) import qualified Development.IDE.Types.Logger as Logger import Ide.Arguments (Arguments (..), @@ -62,24 +64,28 @@ main = do liftIO $ (cb1 <> cb2) env } - let (minPriority, logFilePath, includeExamplePlugins) = + let (argsTesting, minPriority, logFilePath, includeExamplePlugins) = case args of Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> let minPriority = if argsDebugOn || argsTesting then Debug else Info - in (minPriority, argsLogFile, argsExamplePlugin) - _ -> (Info, Nothing, False) + in (argsTesting, minPriority, argsLogFile, argsExamplePlugin) + _ -> (False, Info, Nothing, False) withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do let - recorder = cmapWithPrio pretty $ mconcat + recorder = cmapWithPrio (pretty &&& id) $ mconcat [textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) + & cmapWithPrio fst , lspMessageRecorder & cfilter (\WithPriority{ priority } -> priority >= Error) - & cmapWithPrio renderDoc + & cmapWithPrio (renderDoc . fst) , lspLogRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) + & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions . fst) + -- do not log heap stats to the LSP log as they interfere with the + -- ability of lsp-test to detect a stuck server in tests and benchmarks + & if argsTesting then cfilter (not . heapStats . snd . payload) else id ] plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) @@ -96,3 +102,7 @@ renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep issueTrackerUrl :: Doc a issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" + +heapStats :: Log -> Bool +heapStats (LogIdeMain (IdeMain.LogIDEMain (GhcideMain.LogHeapStats _))) = True +heapStats _ = False