Merge branch 'fix-stuck-at-exit' into soulomoon/mark-dirty-keys-sync-…

…to-hls-graph1

.github/workflows/test.yml

@@ -61,6 +61,8 @@ jobs:
     needs:
       - pre_job
     runs-on: ${{ matrix.os }}
+    env:
+      LSP_TEST_LOG_STDERR: 1
     strategy:
       # We don't want to fail fast.
       # We used to fail fast, to avoid caches of failing PRs to overpopulate the CI

ghcide/exe/Main.hs

@@ -21,7 +21,7 @@ import qualified Development.IDE.Main                     as IDEMain
 import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry
 import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde
 import           Development.IDE.Types.Options
-import           Ide.Logger                               (LoggingColumn (DataColumn, PriorityColumn),
+import           Ide.Logger                               (LoggingColumn (..),
                                                            Pretty (pretty),
                                                            Priority (Debug, Error, Info),
                                                            WithPriority (WithPriority, priority),
@@ -73,7 +73,7 @@ main = withTelemetryRecorder $ \telemetryRecorder -> do
     -- stderr recorder just for plugin cli commands
     pluginCliRecorder <-
       cmapWithPrio pretty
-      <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])
+      <$> makeDefaultStderrRecorder (Just [ThreadIdColumn, PriorityColumn, DataColumn])
 
     let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder))
     -- WARNING: If you write to stdout before runLanguageServer

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

@@ -93,7 +93,8 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
             mainRule
 
 -- | Shutdown the Compiler Service.
-shutdown :: IdeState -> IO ()
+-- shutdown :: Recorder (WithPriority Log) -> IdeState -> IO ()
+shutdown :: Recorder (WithPriority Shake.Log) -> IdeState -> IO ()
 shutdown = shakeShut
 
 -- This will return as soon as the result of the action is

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

@@ -75,6 +75,7 @@ module Development.IDE.Core.Shake(
     VFSModified(..), getClientConfigAction,
     ) where
 
+import           Control.Concurrent                     (tryReadMVar, withMVar)
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Concurrent.STM.Stats           (atomicallyNamed)
@@ -196,6 +197,7 @@ data Log
   | LogShakeGarbageCollection !T.Text !Int !Seconds
   -- * OfInterest Log messages
   | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
+  | LogTimeOutShuttingDownWaitForSessionVar !Seconds
   deriving Show
 
 instance Pretty Log where
@@ -239,6 +241,8 @@ instance Pretty Log where
     LogSetFilesOfInterest ofInterest ->
         "Set files of interst to" <> Pretty.line
             <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)
+    LogTimeOutShuttingDownWaitForSessionVar seconds ->
+        "Timed out waiting for session var after" <+> pretty seconds <+> "seconds"
 
 -- | We need to serialize writes to the database, so we send any function that
 -- needs to write to the database over the channel, where it will be picked up by
@@ -714,16 +718,21 @@ shakeSessionInit recorder ide@IdeState{..} = do
     putMVar shakeSession initSession
     logWith recorder Debug LogSessionInitialised
 
-shakeShut :: IdeState -> IO ()
-shakeShut IdeState{..} = do
-    runner <- tryReadMVar shakeSession
-    -- Shake gets unhappy if you try to close when there is a running
-    -- request so we first abort that.
-    for_ runner cancelShakeSession
-    void $ shakeDatabaseProfile shakeDb
-    progressStop $ progress shakeExtras
-    stopMonitoring
-
+shakeShut :: Recorder (WithPriority Log) -> IdeState -> IO ()
+shakeShut recorder IdeState{..} = do
+    res <- timeout 1 $ withMVar shakeSession $ \runner -> do
+        -- Shake gets unhappy if you try to close when there is a running
+        -- request so we first abort that.
+        cancelShakeSession runner
+        void $ shakeDatabaseProfile shakeDb
+        -- might hang if there are still running
+        progressStop $ progress shakeExtras
+        stopMonitoring
+    case res of
+        Nothing -> do
+            logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1
+            stopMonitoring
+        Just _ -> pure ()
 
 -- | This is a variant of withMVar where the first argument is run unmasked and if it throws
 -- an exception, the previous value is restored while the second argument is executed masked.

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -35,6 +35,7 @@ import qualified Colog.Core                            as Colog
 import           Control.Monad.IO.Unlift               (MonadUnliftIO)
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.Shake            hiding (Log, Priority)
+import qualified Development.IDE.Core.Shake            as Shake
 import           Development.IDE.Core.Tracing
 import qualified Development.IDE.Session               as Session
 import           Development.IDE.Types.Shake           (WithHieDb)
@@ -49,6 +50,7 @@ data Log
   | LogReactorThreadStopped
   | LogCancelledRequest !SomeLspId
   | LogSession Session.Log
+  | LogShake Shake.Log
   | LogLspServer LspServerLog
   | LogServerShutdownMessage
   deriving Show
@@ -265,7 +267,7 @@ shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_
     -- stop the reactor to free up the hiedb connection
     liftIO stopReactor
     -- flush out the Shake session to record a Shake profile if applicable
-    liftIO $ shakeShut ide
+    liftIO $ shakeShut (cmapWithPrio LogShake recorder) ide
     resp $ Right Null
 
 exitHandler :: IO () -> LSP.Handlers (ServerM c)

ghcide/test/exe/Main.hs

@@ -49,6 +49,7 @@ import           CompletionTests
 import           CPPTests
 import           CradleTests
 import           DependentFileTest
+import           Development.IDE              (LoggingColumn (..))
 import           DiagnosticTests
 import           ExceptionTests
 import           FindDefinitionAndHoverTests
@@ -74,7 +75,7 @@ import           WatchedFileTests
 
 main :: IO ()
 main = do
-  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])
+  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [ThreadIdColumn, PriorityColumn, DataColumn])
 
   let docWithFilteredPriorityRecorder =
         docWithPriorityRecorder

hls-test-utils/src/Test/Hls/FileSystem.hs

@@ -115,7 +115,6 @@ materialise rootDir' fileTree testDataDir' = do
       copyDir' root dir = do
         files <- fmap FP.normalise . lines <$> withCurrentDirectory (testDataDir </> dir) (readProcess "git" ["ls-files", "--cached", "--modified", "--others"] "")
         mapM_ (createDirectoryIfMissing True . ((root </>) . takeDirectory)) files
-        mapM_ (\f -> putStrLn $ (testDataDir </> dir </> f) <> ":" <> (root </> f) ) files
         mapM_ (\f -> copyFile (testDataDir </> dir </> f) (root </> f)) files
         return ()