Process notifications asynchronously

ghcide-test/exe/Main.hs

@@ -63,6 +63,7 @@ import           ReferenceTests
 import           ResolveTests
 import           RootUriTests
 import           SafeTests
+import           ShakeRestartTests
 import           SymlinkTests
 import           THTests
 import           UnitTests
@@ -105,4 +106,5 @@ main = do
     , GarbageCollectionTests.tests
     , HieDbRetry.tests
     , ExceptionTests.tests
+    , ShakeRestartTests.tests
     ]

ghcide-test/exe/ShakeRestartTests.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module ShakeRestartTests (tests) where
+
+import           Control.Concurrent.STM
+import           Data.IORef
+import           Data.IORef.Extra           (atomicModifyIORef'_)
+import           Development.IDE.Core.Shake
+import           Development.IDE.Graph      (newKey)
+import           Language.LSP.VFS
+import           Test.Tasty
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "shake restart merging"
+    [ testCase "newestVFSModified" $ do
+        let vfs1 = VFSModified (VFS mempty)
+        newestVFSModified VFSUnmodified VFSUnmodified @?= VFSUnmodified
+        newestVFSModified vfs1 VFSUnmodified @?= vfs1
+        newestVFSModified VFSUnmodified vfs1 @?= vfs1
+
+    , testCase "mergePendingRestart Nothing" $ do
+        let p = PendingRestart VFSUnmodified [] ["reason"] [] []
+        if mergePendingRestart p Nothing == p
+          then pure ()
+          else assertFailure "merging with nothing should get new"
+
+    , testCase "mergePendingRestart Just" $ do
+        done1 <- newEmptyTMVarIO
+        done2 <- newEmptyTMVarIO
+        let key1 = newKey ("1" :: String)
+            key2 = newKey ("2" :: String)
+            p1 = PendingRestart VFSUnmodified [pure [key1]] ["r1"] [] [done1]
+            p2 = PendingRestart VFSUnmodified [pure [key2]] ["r2"] [] [done2]
+            merged = mergePendingRestart p1 (Just p2)
+
+        pendingRestartReasons merged @?= ["r1", "r2"]
+        keys <- sequence $ pendingRestartActionBetweenSessions merged
+        concat keys @?= [key2, key1]
+
+    , testCase "RestartSlot coalescing" $ do
+        slot <- newRestartSlot
+        let p1 = PendingRestart VFSUnmodified [] ["r1"] [] []
+            p2 = PendingRestart VFSUnmodified [] ["r2"] [] []
+
+        atomicModifyIORef'_ (queuedRestart slot) $ Just . mergePendingRestart p1
+        atomicModifyIORef'_ (queuedRestart slot) $ Just . mergePendingRestart p2
+
+        res <- atomicModifyIORef' (queuedRestart slot) (Nothing,)
+        case res of
+            Nothing -> assertFailure "Should have a pending restart"
+            Just p  -> pendingRestartReasons p @?= ["r2", "r1"]
+    ]
+
+instance Eq VFSModified where
+    VFSUnmodified == VFSUnmodified             = True
+    VFSModified (VFS _) == VFSModified (VFS _) = True
+    _ == _                                     = False
+
+instance Eq PendingRestart where
+    p1 == p2 = pendingRestartVFS p1 == pendingRestartVFS p2 &&
+               pendingRestartReasons p1 == pendingRestartReasons p2

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

@@ -729,7 +729,7 @@ checkInCache sessionState ncfp = runMaybeT $ do
 
 -- | Modify the shake state.
 data SessionShake = SessionShake
-  { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
+  { restartSession :: VFSModified -> T.Text -> [DelayedAction ()] -> IO [Key] -> IO ()
   , invalidateCache :: IO Key
   , enqueueActions :: DelayedAction () -> IO (IO ())
   }

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

@@ -280,7 +280,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do
           AlwaysCheck -> True
           CheckOnSave -> saved
           _           -> False
-    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do
+    restartShakeSession (shakeExtras state) vfs (T.pack (fromNormalizedFilePath nfp ++ " (modified)")) [] $ do
         keys<-actionBefore
         return (toKey GetModificationTime nfp:keys)
     when checkParents $
@@ -302,7 +302,7 @@ 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 :: VFSModified -> IdeState -> T.Text -> IO [Key] -> IO ()
 setSomethingModified 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)