Fix hls-graph: phantom dependencies invoke in branching deps (resolve #3423)

bench/config.yaml

@@ -25,6 +25,8 @@ examples:
     modules:
         - src/Distribution/Simple.hs
         - src/Distribution/Types/Module.hs
+        #- src/Distribution/Simple/Configure.hs
+        #- src/Distribution/Simple/BuildTarget.hs
     extra-args: [] # extra HLS command line args
   # Small-sized project with TH
   - name: lsp-types
@@ -94,6 +96,7 @@ experiments:
     - "edit-header"
     - "edit"
     - "hover"
+    - "semanticTokens"
     - "hover after edit"
     # - "hover after cradle edit"
     - "getDefinition"
@@ -129,7 +132,7 @@ versions:
 # WARNING: Currently bench versions later than e4234a3a5e347db249fccefb8e3fb36f89e8eafb
 # will be unable to send plugin configurations to earlier HLS versions. This causes
 # all plugins in those versions to always be enabled.
-# In addition bench proactively disables all plugins it knows about besides the 
+# In addition bench proactively disables all plugins it knows about besides the
 # ones in the following list. However because it can only disable plugins it
 # knows about, any plugins that are in old versions but were removed from HLS
 # before the current bench will not be disabled.
@@ -194,6 +197,7 @@ configurations:
   - qualifyImportedNames
   - rename
   - stylish-haskell
+  - semanticTokens
 # - alternateNumberFormat
 # - callHierarchy
 # - changeTypeSignature

ghcide-bench/src/Experiments.hs

@@ -26,7 +26,8 @@ import           Control.Applicative.Combinators    (skipManyTill)
 import           Control.Concurrent.Async           (withAsync)
 import           Control.Exception.Safe             (IOException, handleAny,
                                                      try)
-import           Control.Lens                       (_Just, (&), (.~), (^.))
+import           Control.Lens                       (_Just, (&), (.~), (^.),
+                                                     (^?))
 import           Control.Lens.Extras                (is)
 import           Control.Monad.Extra                (allM, forM, forM_, forever,
                                                      unless, void, when,
@@ -100,7 +101,19 @@ allWithIdentifierPos f docs = case applicableDocs of
 
 experiments :: HasConfig => [Bench]
 experiments =
-    [ ---------------------------------------------------------------------------------------
+    [
+      bench "semanticTokens" $ \docs -> do
+        liftIO $ putStrLn "Starting semanticTokens"
+        r <- forM docs $ \DocumentPositions{..} -> do
+            changeDoc doc [charEdit stringLiteralP]
+            waitForProgressStart
+            waitForProgressDone
+            tks <- getSemanticTokens doc
+            case tks ^? LSP._L of
+                Just _  -> return True
+                Nothing -> return False
+        return $ and r,
+      ---------------------------------------------------------------------------------------
       bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->
         isJust <$> getHover doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
@@ -316,7 +329,7 @@ versionP = maybeReader $ extract . readP_to_S parseVersion
       extract parses = listToMaybe [ res | (res,"") <- parses]
 
 output :: (MonadIO m, HasConfig) => String -> m ()
-output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn
+output = if quiet ?config then (\_ -> pure ()) else liftIO . putStrLn
 
 ---------------------------------------------------------------------------------------
 
@@ -597,7 +610,7 @@ callCommandLogging cmd = do
 setup :: HasConfig => IO SetupResult
 setup = do
 --   when alreadyExists $ removeDirectoryRecursive examplesPath
-  benchDir <- case exampleDetails(example ?config) of
+  benchDir <- case exampleDetails (example ?config) of
       ExamplePath examplePath -> do
           let hieYamlPath = examplePath </> "hie.yaml"
           alreadyExists <- doesFileExist hieYamlPath
@@ -661,7 +674,7 @@ setup = do
 
   whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
 
-  let cleanUp = case exampleDetails(example ?config) of
+  let cleanUp = case exampleDetails (example ?config) of
         ExampleHackage _  -> removeDirectoryRecursive examplesPath
         ExampleScript _ _ -> removeDirectoryRecursive examplesPath
         ExamplePath _     -> return ()

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

@@ -12,6 +12,7 @@ module Development.IDE.Graph.Database(
     ,shakeGetBuildEdges) where
 import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Dynamic
+import           Data.Foldable                           (fold)
 import           Data.Maybe
 import           Development.IDE.Graph.Classes           ()
 import           Development.IDE.Graph.Internal.Action

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

@@ -38,7 +38,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 alwaysRerun :: Action ()
 alwaysRerun = do
     ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)
+    liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>)
 
 -- No-op for now
 reschedule :: Double -> Action ()
@@ -120,7 +120,7 @@ apply ks = do
     stack <- Action $ asks actionStack
     (is, vs) <- liftIO $ build db stack ks
     ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>)
+    liftIO $ modifyIORef' ref (ResultDeps [fromListKeySet $ toList is] <>)
     pure vs
 
 -- | Evaluate a list of keys without recording any dependencies.

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

@@ -3,9 +3,9 @@
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase         #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeFamilies       #-}
-{-# LANGUAGE ViewPatterns       #-}
 
 module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
 
@@ -25,7 +25,7 @@ import           Control.Monad.Trans.Reader
 import qualified Control.Monad.Trans.State.Strict     as State
 import           Data.Dynamic
 import           Data.Either
-import           Data.Foldable                        (for_, traverse_)
+import           Data.Foldable                        (fold, for_, traverse_)
 import           Data.IORef.Extra
 import           Data.List.NonEmpty                   (unzip)
 import           Data.Maybe
@@ -133,26 +133,41 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do
                 waitAll
                 pure results
 
+isDirty :: Foldable t => Result -> t (a, Result) -> Bool
+isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)
+
+-- | Refresh dependencies for a key and compute the key:
+-- The refresh the deps linearly(last computed order of the deps for the key).
+-- If any of the deps is dirty in the process, we jump to the actual computation of the key
+-- and shortcut the refreshing of the rest of the deps.
+-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.
+--   This assumes that the implementation will be a lookup
+-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself
+refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result)
+refreshDeps visited db stack key result = \case
+    -- no more deps to refresh
+    [] -> pure $ compute db stack key RunDependenciesSame (Just result)
+    (dep:deps) -> do
+        let newVisited = dep <> visited
+        res <- builder db stack (toListKeySet (dep `differenceKeySet` visited))
+        case res of
+            Left res ->  if isDirty result res
+                -- restart the computation if any of the deps are dirty
+                then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result)
+                -- else kick the rest of the deps
+                else refreshDeps newVisited db stack key result deps
+            Right iores -> asyncWithCleanUp $ liftIO $ do
+                res <- iores
+                if isDirty result res
+                    then compute db stack key RunDependenciesChanged (Just result)
+                    else join $ runAIO $ refreshDeps newVisited db stack key result deps
+
 -- | Refresh a key:
---     * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.
---       This assumes that the implementation will be a lookup
---     * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself
 refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
 -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
 refresh db stack key result = case (addStack key stack, result) of
     (Left e, _) -> throw e
-    (Right stack, Just me@Result{resultDeps = ResultDeps (toListKeySet -> deps)}) -> do
-        res <- builder db stack deps
-        let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)
-        case res of
-            Left res ->
-                if isDirty res
-                    then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
-                    else pure $ compute db stack key RunDependenciesSame result
-            Right iores -> asyncWithCleanUp $ liftIO $ do
-                res <- iores
-                let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame
-                compute db stack key mode result
+    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps)
     (Right stack, _) ->
         asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
 
@@ -173,7 +188,7 @@ compute db@Database{..} stack key mode result = do
         previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
     case getResultDepsDefault mempty actualDeps of
-        deps | not(nullKeySet deps)
+        deps | not (nullKeySet deps)
             && runChanged /= ChangedNothing
                     -> do
             -- IMPORTANT: record the reverse deps **before** marking the key Clean.

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

@@ -12,6 +12,7 @@ import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.Char8              as LBS
 import           Data.Char
 import           Data.Dynamic                            (toDyn)
+import           Data.Foldable                           (fold)
 import qualified Data.HashMap.Strict                     as Map
 import           Data.List                               (dropWhileEnd, foldl',
                                                           intercalate,

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

@@ -12,6 +12,7 @@ import           Data.Aeson                         (FromJSON, ToJSON)
 import           Data.Bifunctor                     (second)
 import qualified Data.ByteString                    as BS
 import           Data.Dynamic
+import           Data.Foldable                      (fold)
 import qualified Data.HashMap.Strict                as Map
 import           Data.IORef
 import           Data.List                          (intercalate)
@@ -144,16 +145,20 @@ data Result = Result {
     resultData      :: !BS.ByteString
     }
 
-data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet
+-- Notice, invariant to maintain:
+-- the ![KeySet] in ResultDeps need to be stored in reverse order,
+-- so that we can append to it efficiently, and we need the ordering
+-- so we can do a linear dependency refreshing in refreshDeps.
+data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet]
   deriving (Eq, Show)
 
 getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
-getResultDepsDefault _ (ResultDeps ids)      = ids
+getResultDepsDefault _ (ResultDeps ids)      = fold ids
 getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
 getResultDepsDefault def UnknownDeps         = def
 
 mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
-mapResultDeps f (ResultDeps ids)      = ResultDeps $ f ids
+mapResultDeps f (ResultDeps ids)      = ResultDeps $ fmap f ids
 mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
 mapResultDeps _ UnknownDeps           = UnknownDeps
 

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
@@ -40,7 +42,7 @@ spec = do
           apply1 theKey
       res `shouldBe` [True]
       Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
-      resultDeps res `shouldBe` ResultDeps (singletonKeySet $ newKey (Rule @()))
+      resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())]
     it "tracks reverse dependencies" $ do
       db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do
         ruleUnit
@@ -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 once 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

shake-bench/src/Development/Benchmark/Rules.hs

@@ -333,7 +333,7 @@ benchRules build MkBenchRules{..} = do
              ++ concat
                 [[ "-h"
                   , "-i" <> show i
-                  , "-po" <> outHp
+                  , "-po" <> dropExtension outHp
                   , "-qg"]
                  | CheapHeapProfiling i <- [prof]]
              ++ ["-RTS"]