Fix resultBuilt(dirty mechanism) in hls-graph (#4238)

soulomoon · michaelpj · web-flow · commit 322ac3505c31 · 2024-06-03T15:37:53.000Z
* clarify dirty in hls-graph

* fix comment

* hls-graph add `compute` test

* move test to better place

* add detailed test

* fix comment

---------

Co-authored-by: Michael Peyton Jones &lt;me@michaelpj.com&gt;
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -7,7 +7,7 @@
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeFamilies       #-}
 
-module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
+module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
 
 import           Prelude                              hiding (unzip)
 
@@ -133,6 +133,9 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do
                 waitAll
                 pure results
 
+
+-- | isDirty
+-- only dirty when it's build time is older than the changed time of one of its dependencies
 isDirty :: Foldable t => Result -> t (a, Result) -> Bool
 isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)
 
@@ -179,14 +182,22 @@ compute db@Database{..} stack key mode result = do
     deps <- newIORef UnknownDeps
     (execution, RunResult{..}) <-
         duration $ runReaderT (fromAction act) $ SAction db deps stack
-    built <- readTVarIO databaseStep
+    curStep <- readTVarIO databaseStep
     deps <- readIORef deps
-    let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result
-        built' = if runChanged /= ChangedNothing then built else changed
-        -- only update the deps when the rule ran with changes
+    let lastChanged = maybe curStep resultChanged result
+    let lastBuild = maybe curStep resultBuilt result
+    -- changed time is always older than or equal to build time
+    let (changed, built) =  case runChanged of
+            -- some thing changed
+            ChangedRecomputeDiff -> (curStep, curStep)
+            -- recomputed is the same
+            ChangedRecomputeSame -> (lastChanged, curStep)
+            -- nothing changed
+            ChangedNothing       -> (lastChanged, lastBuild)
+    let -- only update the deps when the rule ran with changes
         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
         previousDeps= maybe UnknownDeps resultDeps result
-    let res = Result runValue built' changed built actualDeps execution runStore
+    let res = Result runValue built changed curStep actualDeps execution runStore
     case getResultDepsDefault mempty actualDeps of
         deps | not (nullKeySet deps)
             && runChanged /= ChangedNothing
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -84,7 +84,7 @@ getDatabase = Action $ asks actionDatabase
 data ShakeDatabase = ShakeDatabase !Int [Action ()] Database
 
 newtype Step = Step Int
-    deriving newtype (Eq,Ord,Hashable)
+    deriving newtype (Eq,Ord,Hashable,Show)
 
 ---------------------------------------------------------------------
 -- Keys
@@ -187,7 +187,6 @@ instance NFData RunMode where rnf x = x `seq` ()
 -- | How the output of a rule has changed.
 data RunChanged
     = ChangedNothing -- ^ Nothing has changed.
-    | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely).
     | ChangedRecomputeSame -- ^ I recomputed the value and it was the same.
     | ChangedRecomputeDiff -- ^ I recomputed the value and it was different.
       deriving (Eq,Show,Generic)
diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs
@@ -3,11 +3,14 @@
 
 module ActionSpec where
 
+import           Control.Concurrent                      (MVar, readMVar)
 import qualified Control.Concurrent                      as C
 import           Control.Concurrent.STM
+import           Control.Monad.IO.Class                  (MonadIO (..))
 import           Development.IDE.Graph                   (shakeOptions)
 import           Development.IDE.Graph.Database          (shakeNewDatabase,
-                                                          shakeRunDatabase)
+                                                          shakeRunDatabase,
+                                                          shakeRunDatabaseForKeys)
 import           Development.IDE.Graph.Internal.Database (build, incDatabase)
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Types
@@ -16,15 +19,50 @@ import           Example
 import qualified StmContainers.Map                       as STM
 import           Test.Hspec
 
+
+
 spec :: Spec
 spec = do
+  describe "apply1" $ it "Test build update, Buggy dirty mechanism in hls-graph #4237" $ do
+    let ruleStep1 :: MVar Int -> Rules ()
+        ruleStep1 m = addRule $ \CountRule _old mode -> do
+            -- depends on ruleSubBranch, it always changed if dirty
+            _ :: Int <- apply1 SubBranchRule
+            let r = 1
+            case mode of
+                -- it update the built step
+                RunDependenciesChanged -> do
+                    _ <- liftIO $ C.modifyMVar m $ \x -> return (x+1, x)
+                    return $ RunResult ChangedRecomputeSame "" r (return ())
+                -- this won't update the built step
+                RunDependenciesSame ->
+                    return $ RunResult ChangedNothing "" r (return ())
+    count <- C.newMVar 0
+    count1 <- C.newMVar 0
+    db <- shakeNewDatabase shakeOptions $ do
+      ruleSubBranch count
+      ruleStep1 count1
+    -- bootstrapping the database
+    _ <- shakeRunDatabase db $ pure $ apply1 CountRule -- count = 1
+    let child = newKey SubBranchRule
+    let parent = newKey CountRule
+    -- instruct to RunDependenciesChanged then CountRule should be recomputed
+    -- result should be changed 0, build 1
+    _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] -- count = 2
+    -- since child changed = parent build
+    -- instruct to RunDependenciesSame then CountRule should not be recomputed
+    -- result should be changed 0, build 1
+    _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2
+    -- invariant child changed = parent build should remains after RunDependenciesSame
+    -- this used to be a bug, with additional computation, see https://github.com/haskell/haskell-language-server/pull/4238
+    _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2
+    c1 <- readMVar count1
+    c1 `shouldBe` 2
   describe "apply1" $ do
     it "computes a rule with no dependencies" $ do
-      db <- shakeNewDatabase shakeOptions $ do
-        ruleUnit
+      db <- shakeNewDatabase shakeOptions ruleUnit
       res <- shakeRunDatabase db $
-        pure $ do
-          apply1 (Rule @())
+        pure $ apply1 (Rule @())
       res `shouldBe` [()]
     it "computes a rule with one dependency" $ do
       db <- shakeNewDatabase shakeOptions $ do
@@ -38,8 +76,7 @@ spec = do
         ruleBool
       let theKey = Rule @Bool
       res <- shakeRunDatabase db $
-        pure $ do
-          apply1 theKey
+        pure $ apply1 theKey
       res `shouldBe` [True]
       Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
       resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())]
@@ -49,14 +86,12 @@ spec = do
         ruleBool
       let theKey = Rule @Bool
       res <- shakeRunDatabase db $
-        pure $ do
-          apply1 theKey
+        pure $ apply1 theKey
       res `shouldBe` [True]
       Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues
-      keyReverseDeps `shouldBe` (singletonKeySet $ newKey theKey)
+      keyReverseDeps `shouldBe` singletonKeySet (newKey theKey)
     it "rethrows exceptions" $ do
-      db <- shakeNewDatabase shakeOptions $ do
-        addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"
+      db <- shakeNewDatabase shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"
       let res = shakeRunDatabase db $ pure $ apply1 (Rule @())
       res `shouldThrow` anyErrorCall
     it "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ do
@@ -81,18 +116,16 @@ spec = do
       countRes <- build theDb emptyStack [SubBranchRule]
       snd countRes `shouldBe` [1 :: Int]
 
-  describe "applyWithoutDependency" $ do
-    it "does not track dependencies" $ do
-      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
-        ruleUnit
-        addRule $ \Rule _old _mode -> do
-            [()] <- applyWithoutDependency [Rule]
-            return $ RunResult ChangedRecomputeDiff "" True $ return ()
+  describe "applyWithoutDependency" $ it "does not track dependencies" $ do
+    db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
+      ruleUnit
+      addRule $ \Rule _old _mode -> do
+          [()] <- applyWithoutDependency [Rule]
+          return $ RunResult ChangedRecomputeDiff "" True $ return ()
 
-      let theKey = Rule @Bool
-      res <- shakeRunDatabase db $
-        pure $ do
-          applyWithoutDependency [theKey]
-      res `shouldBe` [[True]]
-      Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
-      resultDeps res `shouldBe` UnknownDeps
+    let theKey = Rule @Bool
+    res <- shakeRunDatabase db $
+      pure $ applyWithoutDependency [theKey]
+    res `shouldBe` [[True]]
+    Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
+    resultDeps res `shouldBe` UnknownDeps
diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs
@@ -2,16 +2,18 @@
 
 module DatabaseSpec where
 
-import           Development.IDE.Graph                 (shakeOptions)
-import           Development.IDE.Graph.Database        (shakeNewDatabase,
-                                                        shakeRunDatabase)
-import           Development.IDE.Graph.Internal.Action (apply1)
-import           Development.IDE.Graph.Internal.Rules  (addRule)
+import           Development.IDE.Graph                   (newKey, shakeOptions)
+import           Development.IDE.Graph.Database          (shakeNewDatabase,
+                                                          shakeRunDatabase)
+import           Development.IDE.Graph.Internal.Action   (apply1)
+import           Development.IDE.Graph.Internal.Database (compute, incDatabase)
+import           Development.IDE.Graph.Internal.Rules    (addRule)
 import           Development.IDE.Graph.Internal.Types
 import           Example
-import           System.Time.Extra                     (timeout)
+import           System.Time.Extra                       (timeout)
 import           Test.Hspec
 
+
 spec :: Spec
 spec = do
     describe "Evaluation" $ do
@@ -23,3 +25,25 @@ spec = do
                     return $ RunResult ChangedRecomputeDiff "" () (return ())
             let res = shakeRunDatabase db $ pure $ apply1 (Rule @())
             timeout 1 res `shouldThrow` \StackException{} -> True
+
+    describe "compute" $ do
+      it "build step and changed step updated correctly" $ do
+        (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
+          ruleStep
+
+        let k = newKey $ Rule @()
+        -- ChangedRecomputeSame
+        r1@Result{resultChanged=rc1, resultBuilt=rb1} <- compute theDb emptyStack k RunDependenciesChanged Nothing
+        incDatabase theDb Nothing
+        -- ChangedRecomputeSame
+        r2@Result{resultChanged=rc2, resultBuilt=rb2} <- compute theDb emptyStack k RunDependenciesChanged (Just r1)
+        incDatabase theDb Nothing
+        -- changed Nothing
+        Result{resultChanged=rc3, resultBuilt=rb3} <- compute theDb emptyStack k RunDependenciesSame (Just r2)
+        rc1 `shouldBe` Step 0
+        rc2 `shouldBe` Step 0
+        rc3 `shouldBe` Step 0
+
+        rb1 `shouldBe` Step 0
+        rb2 `shouldBe` Step 1
+        rb3 `shouldBe` Step 1
diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs
@@ -20,6 +20,12 @@ instance Typeable a => Show (Rule a) where
 
 type instance RuleResult (Rule a) = a
 
+ruleStep :: Rules ()
+ruleStep = addRule $ \(Rule :: Rule ()) _old mode -> do
+    case mode of
+        RunDependenciesChanged -> return $ RunResult ChangedRecomputeSame "" () (return ())
+        RunDependenciesSame -> return $ RunResult ChangedNothing "" () (return ())
+
 ruleUnit :: Rules ()
 ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do
     return $ RunResult ChangedRecomputeDiff "" () (return ())
@@ -62,3 +68,7 @@ ruleSubBranch :: C.MVar Int -> Rules ()
 ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do
     r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x)
     return $ RunResult ChangedRecomputeDiff "" r (return ())
+
+data CountRule = CountRule
+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)
+type instance RuleResult CountRule = Int
