time out the shakeShut

Author: soulomoon

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

@@ -197,6 +197,7 @@ data Log
   | LogShakeGarbageCollection !T.Text !Int !Seconds
   -- * OfInterest Log messages
   | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
+  | LogTimeOutShuttingDownWaitForSessionVar !Seconds
   deriving Show
 
 instance Pretty Log where
@@ -240,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
@@ -724,15 +727,18 @@ shakeSessionInit recorder ide@IdeState{..} = do
     putMVar shakeSession initSession
     logWith recorder Debug LogSessionInitialised
 
-shakeShut :: IdeState -> IO ()
-shakeShut IdeState{..} = do
-    runner <- tryTakeMVar 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
+        progressStop $ progress shakeExtras
+        stopMonitoring
+    case res of
+        Nothing -> logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1
+        Just _ -> pure ()
 
 
 -- | This is a variant of withMVar where the first argument is run unmasked and if it throws