wait for shake restart only if needed

Author: soulomoon

ghcide/session-loader/Development/IDE/Session.hs

@@ -68,6 +68,7 @@ import           Ide.Logger                          (Pretty (pretty),
                                                       vcat, viaShow, (<+>))
 import           Ide.Types                           (Config,
                                                       SessionLoadingPreferenceConfig (..),
+                                                      ShouldWait (..),
                                                       sessionLoading)
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Server
@@ -625,7 +626,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
             , ..
             }
           sessionShake = SessionShake
-            { restartSession = restartShakeSession extras
+            { restartSession = restartShakeSession extras ShouldWait
             , invalidateCache = invalidateShakeCache
             , enqueueActions = shakeEnqueue extras
             }

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

@@ -22,6 +22,7 @@ module Development.IDE.Core.FileStore(
     registerFileWatches,
     shareFilePath,
     Log(..),
+    setSomethingModifiedWait,
     ) where
 
 import           Control.Concurrent.STM.Stats                 (STM, atomically)
@@ -279,7 +280,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do
           AlwaysCheck -> True
           CheckOnSave -> saved
           _           -> False
-    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do
+    restartShakeSession (shakeExtras state) ShouldNotWait  vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do
         keys<-actionBefore
         return (toKey GetModificationTime nfp:keys)
 
@@ -299,11 +300,16 @@ typecheckParentsAction recorder nfp = do
 -- | Note that some keys have been modified and restart the session
 --   Only valid if the virtual file system was initialised by LSP, as that
 --   independently tracks which files are modified.
-setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
-setSomethingModified vfs state reason actionBetweenSession = do
+setSomethingModified' :: ShouldWait -> VFSModified -> IdeState -> String -> IO [Key] -> IO ()
+setSomethingModified' shouldWait vfs state reason actionBetweenSession = do
     -- Update database to remove any files that might have been renamed/deleted
     atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
-    void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession
+    void $ restartShakeSession (shakeExtras state) shouldWait vfs reason [] actionBetweenSession
+setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
+setSomethingModified vfs state reason actionBetweenSession = setSomethingModified' ShouldNotWait vfs state reason actionBetweenSession
+
+setSomethingModifiedWait :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
+setSomethingModifiedWait vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool
 registerFileWatches globs = do

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

@@ -190,6 +190,9 @@ import           System.Time.Extra
 import           UnliftIO                                (MonadUnliftIO (withRunInIO),
                                                           newIORef, readIORef)
 
+#if !MIN_VERSION_ghc(9,9,0)
+import           Data.Foldable                           (foldl')
+#endif
 
 
 data Log
@@ -341,7 +344,8 @@ data ShakeExtras = ShakeExtras
     ,ideTesting :: IdeTesting
     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
     ,restartShakeSession
-        :: VFSModified
+        :: ShouldWait
+        -> VFSModified
         -> String
         -> [DelayedAction ()]
         -> IO [Key]
@@ -886,15 +890,21 @@ instance Semigroup ShakeRestartArgs where
 -- | Restart the current 'ShakeSession' with the given system actions.
 --   Any actions running in the current session will be aborted,
 --   but actions added via 'shakeEnqueue' will be requeued.
-shakeRestart :: ShakeControlQueue ->  VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
-shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do
-    waitMVar <- newEmptyMVar
-    -- submit at the head of the queue,
-    -- prefer restart request over any pending actions
-    void $ submitWorkAtHead rts $ Left $
-        toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar]
-    -- Wait until the restart is done
-    takeMVar waitMVar
+shakeRestart :: ShakeControlQueue -> ShouldWait ->  VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
+shakeRestart rts b vfs reason acts ioActionBetweenShakeSession = case b of
+    ShouldWait ->
+        do
+        waitMVar <- newEmptyMVar
+        -- submit at the head of the queue,
+        -- prefer restart request over any pending actions
+        void $ submitWorkAtHead rts $ Left $
+            toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar]
+        -- Wait until the restart is done
+        takeMVar waitMVar
+    ShouldNotWait ->
+        void $ submitWorkAtHead rts $ Left $
+            toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 []
+
 
 dynShakeRestart :: Dynamic -> ShakeRestartArgs
 dynShakeRestart dy = case fromDynamic dy of

hls-plugin-api/src/Ide/Types.hs

@@ -42,7 +42,7 @@ module Ide.Types
 , installSigUsr1Handler
 , lookupCommandProvider
 , ResolveFunction
-, mkResolveHandler
+, mkResolveHandler, ShouldWait(..)
 )
     where
 
@@ -1302,3 +1302,6 @@ installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing
   resolve handlers for the same method, than our assumptions that we never have
   two responses break, and behavior is undefined.
   -}
+
+data ShouldWait = ShouldWait | ShouldNotWait
+    deriving Eq

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

@@ -179,7 +179,7 @@ Then we restart the shake session, so that changes to our virtual files are actu
 -}
 restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO ()
 restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do
-  restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do
+  restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do
     keys <- actionBetweenSession
     return (toKey GetModificationTime file:keys)
 
@@ -188,7 +188,7 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d
 -- rule to get re-run if the file changes on disk.
 restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO ()
 restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do
-  restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do
+  restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do
     keys <- actionBetweenSession
     return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys)
 

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs

@@ -41,7 +41,7 @@ import           Data.String                                  (IsString)
 import           Data.Text                                    (Text)
 import qualified Data.Text                                    as T
 import qualified Data.Text.Utf16.Rope.Mixed                   as Rope
-import           Development.IDE.Core.FileStore               (getUriContents, setSomethingModified)
+import           Development.IDE.Core.FileStore               (getUriContents, setSomethingModifiedWait)
 import           Development.IDE.Core.Rules                   (IdeState,
                                                                runAction)
 import           Development.IDE.Core.Shake                   (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_)
@@ -214,11 +214,11 @@ runEvalCmd recorder plId st mtoken EvalParams{..} =
 
             -- enable codegen for the module which we need to evaluate.
             final_hscEnv <- liftIO $ bracket_
-              (setSomethingModified VFSUnmodified st "Eval" $ do
+              (setSomethingModifiedWait VFSUnmodified st "Eval" $ do
                 queueForEvaluation st nfp
                 return [toKey IsEvaluating nfp]
                 )
-              (setSomethingModified VFSUnmodified st "Eval" $ do
+              (setSomethingModifiedWait VFSUnmodified st "Eval" $ do
                 unqueueForEvaluation st nfp
                 return [toKey IsEvaluating nfp]
                 )