add test to prevent phantom dependencies

Author: soulomoon

hls-graph/test/ActionSpec.hs

@@ -3,15 +3,17 @@
 
 module ActionSpec where
 
+import qualified Control.Concurrent                      as C
 import           Control.Concurrent.STM
-import           Development.IDE.Graph                (shakeOptions)
-import           Development.IDE.Graph.Database       (shakeNewDatabase,
-                                                       shakeRunDatabase)
+import           Development.IDE.Graph                   (shakeOptions)
+import           Development.IDE.Graph.Database          (shakeNewDatabase,
+                                                          shakeRunDatabase)
+import           Development.IDE.Graph.Internal.Database (build, incDatabase)
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Types
 import           Development.IDE.Graph.Rule
 import           Example
-import qualified StmContainers.Map                    as STM
+import qualified StmContainers.Map                       as STM
 import           Test.Hspec
 
 spec :: Spec
@@ -57,6 +59,28 @@ spec = do
         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
+      cond <- C.newMVar True
+      count <- C.newMVar 0
+      (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
+        ruleUnit
+        ruleCond cond
+        ruleSubBranch count
+        ruleWithCond
+      -- build the one with the condition True
+      -- This should call the SubBranchRule once
+      -- cond rule would return different results each time
+      res0 <- build theDb emptyStack [BranchedRule]
+      snd res0 `shouldBe` [1 :: Int]
+      incDatabase theDb Nothing
+      -- build the one with the condition False
+      -- This should not call the SubBranchRule
+      res1 <- build theDb emptyStack [BranchedRule]
+      snd res1 `shouldBe` [2 :: Int]
+    --   SubBranchRule should be recomputed one before this (when the condition was True)
+      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

hls-graph/test/Example.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE TypeFamilies      #-}
 module Example where
 
+import qualified Control.Concurrent            as C
+import           Control.Monad.IO.Class        (liftIO)
 import           Development.IDE.Graph
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Rule
@@ -27,3 +29,36 @@ ruleBool :: Rules ()
 ruleBool = addRule $ \Rule _old _mode -> do
     () <- apply1 Rule
     return $ RunResult ChangedRecomputeDiff "" True
+
+
+data CondRule = CondRule
+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)
+type instance RuleResult CondRule = Bool
+
+
+ruleCond :: C.MVar Bool -> Rules ()
+ruleCond mv = addRule $ \CondRule _old _mode -> do
+    r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x)
+    return $ RunResult ChangedRecomputeDiff "" r
+
+data BranchedRule = BranchedRule
+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)
+type instance RuleResult BranchedRule = Int
+
+ruleWithCond :: Rules ()
+ruleWithCond = addRule $ \BranchedRule _old _mode -> do
+    r <- apply1 CondRule
+    if r then do
+            _ <- apply1 SubBranchRule
+            return $ RunResult ChangedRecomputeDiff "" (1 :: Int)
+         else
+            return $ RunResult ChangedRecomputeDiff "" (2 :: Int)
+
+data SubBranchRule = SubBranchRule
+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)
+type instance RuleResult SubBranchRule = Int
+
+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