Merge branch 'master' into hls-testing

Author: wz1000

exe/Main.hs

@@ -5,17 +5,19 @@
 {-# 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),
                                                cfilter, cmapWithPrio,
                                                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

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

@@ -63,10 +63,10 @@ data State
 -- | State transitions used in 'delayedProgressReporting'
 data Transition = Event ProgressEvent | StopProgress
 
-updateState :: IO () -> Transition -> State -> IO State
+updateState :: IO (Async ()) -> Transition -> State -> IO State
 updateState _      _                    Stopped     = pure Stopped
-updateState start (Event KickStarted)   NotStarted  = Running <$> async start
-updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> async start
+updateState start (Event KickStarted)   NotStarted  = Running <$> start
+updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> start
 updateState _     (Event KickCompleted) (Running a) = cancel a $> NotStarted
 updateState _     (Event KickCompleted) st          = pure st
 updateState _     StopProgress          (Running a) = cancel a $> Stopped
@@ -110,12 +110,13 @@ delayedProgressReporting
   -> Maybe (LSP.LanguageContextEnv c)
   -> ProgressReportingStyle
   -> IO ProgressReporting
-delayedProgressReporting before after lspEnv optProgressStyle = do
+delayedProgressReporting before after Nothing optProgressStyle = noProgressReporting
+delayedProgressReporting before after (Just lspEnv) optProgressStyle = do
     inProgressState <- newInProgress
     progressState <- newVar NotStarted
     let progressUpdate event = updateStateVar $ Event event
         progressStop   =  updateStateVar StopProgress
-        updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressState)
+        updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState)
 
         inProgress = updateStateForFile inProgressState
     return ProgressReporting{..}
@@ -127,11 +128,11 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
             u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
 
             b <- liftIO newBarrier
-            void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
+            void $ LSP.runLspT lspEnv $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
                 LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b
-            ready <- liftIO $ waitBarrier b
-
-            for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
+            liftIO $ async $ do
+                ready <- waitBarrier b
+                LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
             where
                 start id = LSP.sendNotification LSP.SProgress $
                     LSP.ProgressParams