Discard rule results from runs superseded by Shake restarts

ghcide-test/exe/DiagnosticTests.hs

@@ -15,7 +15,8 @@ import           Development.IDE.Test            (diagnostic,
                                                   expectDiagnostics,
                                                   expectDiagnosticsWithTags,
                                                   expectNoMoreDiagnostics,
-                                                  flushMessages, waitForAction)
+                                                  flushMessages, waitForAction,
+                                                  waitForBuildQueue)
 import           Development.IDE.Types.Location
 import qualified Language.LSP.Protocol.Lens      as L
 import           Language.LSP.Protocol.Message
@@ -54,6 +55,20 @@ tests = testGroup "diagnostics"
               }
       changeDoc doc [change]
       expectDiagnostics [("Testing.hs", [])]
+  , testWithDummyPluginEmpty "rapid edits then save does not strand a stale diagnostic" $ do
+      let v rhs = T.unlines ["module Testing where", "foo :: Int", "foo = " <> rhs]
+          whole rhs = TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ v rhs
+      doc <- createDoc "Testing.hs" "haskell" (v "()")
+      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (2, 6), "Couldn't match expected type 'Int' with actual type '()'", Just "GHC-83865")])]
+      changeDoc doc [whole "()"]
+      changeDoc doc [whole "'a'"]
+      changeDoc doc [whole "True"]
+      changeDoc doc [whole "0"]
+      sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams doc Nothing)
+      waitForBuildQueue
+      liftIO $ sleep 0.2
+      flushMessages
+      expectCurrentDiagnostics doc []
   , testWithDummyPluginEmpty "introduce syntax error" $ do
       let content = T.unlines [ "module Testing where" ]
       doc <- createDoc "Testing.hs" "haskell" content

hls-graph/src/Development/IDE/Graph/Internal/Database.hs

@@ -17,7 +17,7 @@ import           Control.Concurrent.Extra
 import           Control.Concurrent.STM.Stats         (STM, atomically,
                                                        atomicallyNamed,
                                                        modifyTVar', newTVarIO,
-                                                       readTVarIO)
+                                                       readTVar, readTVarIO)
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.IO.Class               (MonadIO (liftIO))
@@ -180,10 +180,40 @@ refresh db stack key result = case (addStack key stack, result) of
     (Right stack, _) ->
         asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
 
+{- Note [Discard superseded computations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A restart cancels the running build with an async exception, but the computation
+it spawned can outlive it and finish under a later build. 'compute' stamps the
+result with whatever the step is *now*, so a value read from stale inputs is
+recorded as freshly built and dependents skip recomputing it:
+
+    step 1   build A starts rule R, reading its inputs at step 1
+    step 2   a restart bumps the step to 2 and marks R dirty
+     ...     A finally finishes and, unguarded, commits Clean@2,
+               a stale result, but its timestamp claims it is fresh
+
+Guard: 'compute' samples the step into 'startStep' before running and re-reads it
+before storing.
+
+    startStep == now : commit Clean, the normal path
+    startStep <  now : R was superseded. Mark the key Dirty, keeping the prior
+                       result as payload (as a restart does) so the next build
+                       recomputes it and can still cut off.
+
+A newer build may already own the slot, so demoting blindly would drop its
+in-flight result or dirty its fresh one into a duplicate run. Take care not to
+clobber validly refreshed results:
+
+    Running s : keep if s > startStep
+    Clean r   : keep if resultVisited r > startStep
+-}
+
 -- | Compute a key.
 compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
 -- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined
 compute db@Database{..} stack key mode result = do
+    -- See Note [Discard superseded computations]
+    startStep <- readTVarIO databaseStep
     let act = runRule databaseRules key (fmap resultData result) mode
     deps <- newIORef UnknownDeps
     (execution, RunResult{..}) <-
@@ -218,15 +248,30 @@ compute db@Database{..} stack key mode result = do
                     deps
         _ -> pure ()
     atomicallyNamed "compute and run hook" $ do
-        runHook
-        SMap.focus (updateStatus $ Clean res) key databaseValues
+        -- See Note [Discard superseded computations]
+        stepNow <- readTVar databaseStep
+        if stepNow == startStep
+          then runHook >> SMap.focus (updateStatus $ Clean res) key databaseValues
+          else SMap.focus (demoteSuperseded startStep) key databaseValues
     pure res
 
 updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m ()
 updateStatus res = Focus.alter
     (Just . maybe (KeyDetails res mempty)
     (\it -> it{keyStatus = res}))
 
+-- | Demote a superseded key to Dirty unless a newer build already wrote a result.
+-- See Note [Discard superseded computations].
+demoteSuperseded :: Monad m => Step -> Focus.Focus KeyDetails m ()
+demoteSuperseded startStep = Focus.adjust $ \kd ->
+    let st = keyStatus kd
+    in if newerOwns st then kd else kd{keyStatus = Dirty (getResult st)}
+  where
+    newerOwns (Running s _ _ _) = s > startStep
+    -- resultVisited, since `ChangedNothing` backdates `resultBuilt` time steps.
+    newerOwns (Clean r)         = resultVisited r > startStep
+    newerOwns _                 = False
+
 -- | Returns the set of dirty keys annotated with their age (in # of builds)
 getDirtySet :: Database -> IO [(Key, Int)]
 getDirtySet db = do

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -152,7 +152,7 @@ data Result = Result {
     resultValue     :: !Value,
     resultBuilt     :: !Step, -- ^ the step when it was last recomputed
     resultChanged   :: !Step, -- ^ the step when it last changed
-    resultVisited   :: !Step, -- ^ the step when it was last looked up
+    resultVisited   :: !Step, -- ^ the step when it was last looked up/produced the result.
     resultDeps      :: !ResultDeps,
     resultExecution :: !Seconds, -- ^ How long it took, last time it ran
     resultData      :: !BS.ByteString

hls-graph/test/ActionSpec.hs

@@ -129,3 +129,97 @@ spec = do
     res `shouldBe` [[True]]
     Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
     resultDeps res `shouldBe` UnknownDeps
+
+  describe "Discard superseded computations" $ do
+    it "leaves a key dirty when a restart bumps the step mid-computation" $ do
+      started <- C.newEmptyMVar
+      proceed <- C.newEmptyMVar
+      done    <- C.newEmptyMVar
+      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $
+        addRule $ \(Rule :: Rule ()) _old _mode -> do
+          liftIO $ C.putMVar started ()
+          liftIO $ C.takeMVar proceed
+          return $ RunResult ChangedRecomputeDiff "" () (return ())
+      -- Fork so a restart can bump the step while the rule is still computing.
+      _ <- C.forkIO $ shakeRunDatabase db [apply1 (Rule @())] >>= C.putMVar done
+      C.takeMVar started
+      -- Bumps the step without dirtying anything, so only the guard can leave
+      -- this key dirty.
+      incDatabase theDb (Just [])
+      C.putMVar proceed ()
+      _ <- C.takeMVar done
+      Just status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb
+      case status of
+        Dirty{}   -> pure ()
+        Clean{}   -> expectationFailure "superseded computation was committed clean"
+        Running{} -> expectationFailure "superseded computation left running"
+    it "commits clean when the step does not advance" $ do
+      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $
+        addRule $ \(Rule :: Rule ()) _old _mode ->
+          return $ RunResult ChangedRecomputeDiff "" () (return ())
+      _ <- shakeRunDatabase db [apply1 (Rule @())]
+      Just status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb
+      case status of
+        Clean{} -> pure ()
+        _       -> expectationFailure "expected a clean commit"
+    it "leaves a newer build's Running intact instead of stomping it" $
+      withSupersededRespawn $ \theDb proceedA doneA proceedB doneB -> do
+        -- A finishes while B is still Running{2}. Guard must keep B's Running.
+        C.putMVar proceedA ()
+        _ <- C.takeMVar doneA
+        status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb
+        -- Release B before asserting so its thread finishes.
+        C.putMVar proceedB ()
+        _ <- C.takeMVar doneB
+        case status of
+          Just Running{} -> pure ()
+          Just Dirty{}   -> expectationFailure "superseded build unnecessary marked dirty"
+          Just Clean{}   -> expectationFailure "newer build committed too early"
+          Nothing        -> expectationFailure "key missing from the database"
+    it "leaves a newer build's committed Clean intact instead of dirtying it" $
+      withSupersededRespawn $ \theDb proceedA doneA proceedB doneB -> do
+        -- B commits Clean{2} before A demotes. Guard must keep B's Clean.
+        C.putMVar proceedB ()
+        _ <- C.takeMVar doneB
+        C.putMVar proceedA ()
+        _ <- C.takeMVar doneA
+        status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb
+        case status of
+          Just Clean{}   -> pure ()
+          Just Dirty{}   -> expectationFailure "superseded build unnecessary marked dirty"
+          Just Running{} -> expectationFailure "newer build didn't commit"
+          Nothing        -> expectationFailure "key missing from the database"
+  where
+    -- Two builds of the same key.
+    --
+    -- 1. A, the superseded build, runs at step 1.
+    -- 2. B, the re-spawn, runs at step 2. B's shakeRunDatabase bumps the step
+    --    and re-dirties A's in-flight key, so the rule runs again and leaves B
+    --    Running{2}.
+    --
+    -- Both are started and blocked before the continuation runs. The
+    -- continuation picks the release ordering that decides whether the guard
+    -- meets B as Running or as Clean.
+    withSupersededRespawn
+      :: (Database -> MVar () -> MVar () -> MVar () -> MVar () -> IO ())
+      -> IO ()
+    withSupersededRespawn k = do
+      calls    <- newTVarIO (0 :: Int)
+      startedA <- C.newEmptyMVar
+      proceedA <- C.newEmptyMVar
+      startedB <- C.newEmptyMVar
+      proceedB <- C.newEmptyMVar
+      doneA    <- C.newEmptyMVar
+      doneB    <- C.newEmptyMVar
+      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $
+        addRule $ \(Rule :: Rule ()) _old _mode -> do
+          n <- liftIO $ atomically $ modifyTVar' calls (+1) >> readTVar calls
+          liftIO $ if n == 1
+            then C.putMVar startedA () >> C.takeMVar proceedA
+            else C.putMVar startedB () >> C.takeMVar proceedB
+          return $ RunResult ChangedRecomputeDiff "" () (return ())
+      _ <- C.forkIO $ shakeRunDatabase db [apply1 (Rule @())] >> C.putMVar doneA ()
+      C.takeMVar startedA
+      _ <- C.forkIO $ shakeRunDatabase db [apply1 (Rule @())] >> C.putMVar doneB ()
+      C.takeMVar startedB
+      k theDb proceedA doneA proceedB doneB