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

* 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 <me@michaelpj.com>
2024-09-11 08:45:35 +03:00 · 2024-06-03 23:37:53 +08:00 · 2024-06-03 23:37:53 +08:00 · 322ac3505c
commit 322ac3505c
parent d839b78551
5 changed files with 117 additions and 40 deletions
--- 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
--- 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)
--- 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
--- 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
--- 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