Fix hls-graph: phantom dependencies invoke in branching deps (resolve h…

…askell#3423) (haskell#4087)

phantom depencies is invoke becase dependencies have preconditions in rules, see haskell#3423. This pr is intend to fix that.
This might also fix some of the flaky tests. 

In favor of @wz1000 appoach of running deps linearly. 
It modify the deps result from KeySet to [KeySet] to make sure the result is sorted

we initialy thought it would have performance impact on the build system. But it turns out instead of performance lost, we actaully have performance gain since it avoid building the phantom depencies. 

Overall things have been done:
1. Fix up hls-graph phantom depencies issue by reflesh linear deps in a linear manner.
2. Add semantic tokens bench mark.
3. Add test to hls-graph to ensure phantom depencies would not be invoke.

Result:
Now no more phantom dependencies would be invoked in hls-graph, gaining correctness, less runtime and less mem usage at the some time.

bench/config.yaml

@@ -94,6 +94,7 @@ experiments:
     - "edit-header"
     - "edit"
     - "hover"
+    - "semanticTokens"
     - "hover after edit"
     # - "hover after cradle edit"
     - "getDefinition"
@@ -194,6 +195,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
 
 ---------------------------------------------------------------------------------------
 
@@ -670,7 +683,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

@@ -18,6 +18,7 @@ module Development.IDE.Graph.Internal.Action
 ) where
 
 import           Control.Concurrent.Async
+import           Control.DeepSeq                         (force)
 import           Control.Exception
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
@@ -38,7 +39,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 +121,8 @@ 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) <>)
+    let !ks = force $ fromListKeySet $ toList is
+    liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
     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/Key.hs

@@ -101,7 +101,7 @@ renderKey :: Key -> Text
 renderKey (lookupKeyValue -> KeyValue _ t) = t
 
 newtype KeySet = KeySet IntSet
-  deriving newtype (Eq, Ord, Semigroup, Monoid)
+  deriving newtype (Eq, Ord, Semigroup, Monoid, NFData)
 
 instance Show KeySet where
   showsPrec p (KeySet is)= showParen (p > 10) $

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