Add tests on shake restart merging

Author: crtschin

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 (pure []) ["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 <- pendingRestartActionBetweenSessions merged
+        keys @?= [key2, key1]
+
+    , testCase "RestartSlot coalescing" $ do
+        slot <- newRestartSlot
+        let p1 = PendingRestart VFSUnmodified (pure []) ["r1"] [] []
+            p2 = PendingRestart VFSUnmodified (pure []) ["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/src/Development/IDE/Core/Shake.hs

@@ -72,7 +72,11 @@ module Development.IDE.Core.Shake(
     IndexQueue,
     HieDb,
     HieDbWriter(..),
+    PendingRestart(..),
+    RestartSlot(..),
     addPersistentRule,
+    newestVFSModified,
+    mergePendingRestart,
     garbageCollectDirtyKeys,
     garbageCollectDirtyKeysOlderThan,
     Log(..),
@@ -133,10 +137,8 @@ import           Development.IDE.Core.WorkerThread
 import           Development.IDE.Types.Options          as Options
 import qualified Language.LSP.Protocol.Message          as LSP
 import qualified Language.LSP.Server                    as LSP
-import qualified Language.LSP.VFS                       as VFS
 
 import           Development.IDE.Core.Tracing
-import           Development.IDE.Core.WorkerThread
 #if MIN_VERSION_ghc(9,13,0)
 import           Development.IDE.GHC.Compat             (NameCache,
                                                          NameCacheUpdater,
@@ -830,15 +832,10 @@ mergePendingRestart :: PendingRestart -> Maybe PendingRestart -> PendingRestart
 mergePendingRestart new Nothing = new
 mergePendingRestart new (Just old) = PendingRestart
     { pendingRestartVFS = newestVFSModified (pendingRestartVFS new) (pendingRestartVFS old)
-    , pendingRestartActions = do
-        old' <- pendingRestartActions old
-        new' <- pendingRestartActions new
-        pure $ new' <> old'
     , pendingRestartReasons = pendingRestartReasons new <> pendingRestartReasons old
-    , pendingRestartActionBetweenSessions = do
-        old' <- pendingRestartActionBetweenSessions old
-        new' <- pendingRestartActionBetweenSessions new
-        pure $ new' <> old'
+    -- TODO: Contains a quadratic list append on the number of accumulated shake restarts.
+    , pendingRestartActions = pendingRestartActions old <> pendingRestartActions new
+    , pendingRestartActionBetweenSessions = pendingRestartActionBetweenSessions old <> pendingRestartActionBetweenSessions new
     , pendingRestartDoneSignals = pendingRestartDoneSignals new <> pendingRestartDoneSignals old    }
 
 data RestartSlot = RestartSlot
@@ -931,6 +928,7 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
     return (wait' b >>= either throwIO return)
 
 data VFSModified = VFSUnmodified | VFSModified !VFS
+    deriving Show
 
 -- | Set up a new 'ShakeSession' with a set of initial actions
 --   Will crash if there is an existing 'ShakeSession' running.

haskell-language-server.cabal

@@ -2107,6 +2107,7 @@ test-suite ghcide-tests
     , extra
     , filepath
     , ghcide
+    , hls-graph
     , hls-plugin-api
     , lens
     , list-t
@@ -2174,6 +2175,7 @@ test-suite ghcide-tests
     ResolveTests
     RootUriTests
     SafeTests
+    ShakeRestartTests
     SymlinkTests
     THTests
     UnitTests