implement reverse deps

Author: pepeiborra

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -48,7 +48,6 @@ import           Development.IDE.Import.DependencyInformation
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
-import           Development.IDE.Types.Shake                  (SomeShakeValue)
 import           HieDb.Create                                 (deleteMissingRealFiles)
 import           Ide.Plugin.Config                            (CheckParents (..),
                                                                Config)
@@ -294,7 +293,7 @@ typecheckParentsAction nfp = do
 -- | Note that some keys have been modified and restart the session
 --   Only valid if the virtual file system was initialised by LSP, as that
 --   independently tracks which files are modified.
-setSomethingModified :: IdeState -> [SomeShakeValue] -> IO ()
+setSomethingModified :: IdeState -> [Key] -> IO ()
 setSomethingModified state keys = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $

ghcide/src/Development/IDE/Core/Shake.hs

@@ -214,7 +214,7 @@ data ShakeExtras = ShakeExtras
     , vfs :: VFSHandle
     , defaultConfig :: Config
       -- ^ Default HLS config, only relevant if the client does not provide any Config
-    , dirtyKeys :: IORef (HashSet SomeShakeValue)
+    , dirtyKeys :: IORef (HashSet Key)
       -- ^ Set of dirty rule keys since the last Shake run
     }
 

ghcide/src/Development/IDE/Types/Shake.hs

@@ -8,7 +8,6 @@ module Development.IDE.Types.Shake
     ValueWithDiagnostics (..),
     Values,
     Key (..),
-    SomeShakeValue,
     BadDependency (..),
     ShakeValue(..),
     currentValue,
@@ -22,14 +21,12 @@ import qualified Data.ByteString.Char8                as BS
 import           Data.Dynamic
 import           Data.HashMap.Strict
 import           Data.Hashable
-import           Data.Typeable
 import           Data.Vector                          (Vector)
 import           Development.IDE.Core.PositionMapping
-import           Development.IDE.Graph                (RuleResult,
+import           Development.IDE.Graph                (Key (..), RuleResult,
                                                        ShakeException (shakeExceptionInner))
 import qualified Development.IDE.Graph                as Shake
 import           Development.IDE.Graph.Classes
-import           Development.IDE.Graph.Database       (SomeShakeValue (..))
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           GHC.Generics
@@ -56,26 +53,6 @@ data ValueWithDiagnostics
 -- | The state of the all values and diagnostics
 type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics
 
--- | Key type
-data Key = forall k . (Typeable k, Hashable k, Eq k, NFData k, Show k) => Key k
-
-instance Show Key where
-  show (Key k) = show k
-
-instance Eq Key where
-    Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
-                     | otherwise = False
-
-instance Hashable Key where
-    hashWithSalt salt (Key key) = hashWithSalt salt key
-
-instance Binary Key where
-    get = error "not really"
-    put _ = error "not really"
-
-instance NFData Key where
-    rnf (Key k) = rnf k
-
 -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
 --   which short-circuits the rest of the action
 newtype BadDependency = BadDependency String deriving Show
@@ -87,12 +64,11 @@ isBadDependency x
     | Just (_ :: BadDependency) <- fromException x = True
     | otherwise = False
 
+toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key
+toKey = (Key.) . curry Q
 
-toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue
-toKey = (SomeShakeValue .) . curry Q
-
-toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k, Binary k, NFData k) => k -> SomeShakeValue
-toNoFileKey k = toKey k emptyFilePath
+toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k, Binary k) => k -> Key
+toNoFileKey k = Key $ Q (k, emptyFilePath)
 
 newtype Q k = Q (k, NormalizedFilePath)
     deriving newtype (Eq, Hashable, NFData)

hls-graph/hls-graph.cabal

@@ -45,6 +45,7 @@ library
     , async
     , base >=4.12 && <5
     , bytestring
+    , containers
     , extra
     , primitive
     , shake >= 0.19.4

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

@@ -4,6 +4,7 @@ module Development.IDE.Graph(
     shakeOptions,
     Rules,
     Action, action,
+    Key(..),
     actionFinally, actionBracket, actionCatch,
     Shake.ShakeException(..),
     -- * Configuration

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

@@ -4,7 +4,6 @@
 module Development.IDE.Graph.Database(
     ShakeDatabase,
     ShakeValue,
-    SomeShakeValue(..),
     shakeOpenDatabase,
     shakeRunDatabase,
     shakeRunDatabaseForKeys,
@@ -13,7 +12,6 @@ module Development.IDE.Graph.Database(
 
 import           Data.Dynamic
 import           Data.Maybe
-import           Data.Typeable                           (cast)
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Action
 import           Development.IDE.Graph.Internal.Database
@@ -37,10 +35,7 @@ shakeNewDatabase opts rules = do
     pure $ ShakeDatabase (length actions) actions db
 
 shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
-shakeRunDatabase (ShakeDatabase lenAs1 as1 db) as2 = do
-    incDatabase db
-    as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2
-    return (as, [])
+shakeRunDatabase = shakeRunDatabaseForKeys Nothing
 
 -- Only valid if we never pull on the results, which we don't
 unvoid :: Functor m => m () -> m a
@@ -50,20 +45,15 @@ unvoid = fmap undefined
 shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
 shakeProfileDatabase _ file = writeFile file ""
 
-data SomeShakeValue = forall k . ShakeValue k => SomeShakeValue k
-instance Eq SomeShakeValue where SomeShakeValue a == SomeShakeValue b = cast a == Just b
-instance Hashable SomeShakeValue where hashWithSalt s (SomeShakeValue x) = hashWithSalt s x
-instance Show SomeShakeValue where show (SomeShakeValue x) = show x
-
 type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a, Binary a)
 
 shakeRunDatabaseForKeys
-    :: Maybe [SomeShakeValue]
+    :: Maybe [Key]
       -- ^ Set of keys changed since last run. 'Nothing' means everything has changed
     -> ShakeDatabase
     -> [Action a]
     -> IO ([a], [IO ()])
-shakeRunDatabaseForKeys _keys a b =
-    -- Shake upstream does not accept the set of keys changed yet
-    -- https://github.com/ndmitchell/shake/pull/802
-    shakeRunDatabase a b
+shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
+    incDatabase db keysChanged
+    as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2
+    return (as, [])

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

@@ -7,17 +7,23 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE ViewPatterns        #-}
 
 module Development.IDE.Graph.Internal.Database where
 
 import           Control.Concurrent.Async
 import           Control.Concurrent.Extra
 import           Control.Exception
 import           Control.Monad
+import           Control.Monad.Trans.Class             (lift)
 import           Control.Monad.Trans.Reader
+import qualified Control.Monad.Trans.State.Strict      as State
 import           Data.Dynamic
 import           Data.Either
+import           Data.Foldable                         (traverse_)
 import           Data.IORef.Extra
+import           Data.IntSet                           (IntSet)
+import qualified Data.IntSet                           as Set
 import           Data.Maybe
 import           Data.Tuple.Extra
 import qualified Development.IDE.Graph.Internal.Ids    as Ids
@@ -36,17 +42,31 @@ newDatabase databaseExtra databaseRules = do
     databaseLock <- newLock
     databaseIds <- newIORef Intern.empty
     databaseValues <- Ids.empty
+    databaseReverseDeps <- Ids.empty
+    databaseReverseDepsLock <- newLock
     pure Database{..}
 
--- | Increment the step and mark all ids dirty
-incDatabase :: Database -> IO ()
-incDatabase db = do
-    modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1
+-- | Increment the step and mark dirty
+incDatabase :: Database -> Maybe [Key] -> IO ()
+-- all keys are dirty
+incDatabase db Nothing =
     withLock (databaseLock db) $
-        Ids.forMutate (databaseValues db) $ second $ \case
+        Ids.forMutate (databaseValues db) $ \_ -> second $ \case
             Clean x     -> Dirty (Just x)
             Dirty x     -> Dirty x
             Running _ x -> Dirty x
+-- only some keys are dirty
+incDatabase db (Just kk) = do
+    modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1
+    intern <- readIORef (databaseIds db)
+    let dirtyIds = mapMaybe (`Intern.lookup` intern) kk
+    transitiveDirtyIds <- transitiveDirtySet db dirtyIds
+    withLock (databaseLock db) $
+        Ids.forMutate (databaseValues db) $ \i -> \case
+            (k, Running _ x) -> (k, Dirty x)
+            (k, Clean x) | i `Set.member` transitiveDirtyIds ->
+                (k, Dirty (Just x))
+            other -> other
 
 
 -- | Unwrap and build a list of keys in parallel
@@ -116,17 +136,17 @@ builder db@Database{..} keys = do
 cleanupAsync :: IORef [Async a] -> IO ()
 cleanupAsync ref = mapConcurrently_ uninterruptibleCancel =<< readIORef ref
 
-
 -- | Check if we need to run the database.
 check :: Database -> Key -> Id -> Maybe Result -> IO Result
 check db key id result@(Just me@Result{resultDeps=Just deps}) = do
-    res <- builder db $ map Left deps
-    let dirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) res
-    let mode = if dirty then Shake.RunDependenciesChanged else Shake.RunDependenciesSame
+    mode <- do
+            res <- builder db (map Left deps)
+            let dirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) res
+            return $ if dirty then Shake.RunDependenciesChanged else Shake.RunDependenciesSame
+        -- If I am not dirty then none of my dependencies are, so they must be unchanged
     spawn db key id mode result
 check db key id result = spawn db key id Shake.RunDependenciesChanged result
 
-
 -- | Spawn a new computation to run the action.
 spawn :: Database -> Key -> Id -> Shake.RunMode -> Maybe Result -> IO Result
 spawn db@Database{..} key id mode result = do
@@ -137,10 +157,11 @@ spawn db@Database{..} key id mode result = do
     deps <- readIORef deps
     let changed = if runChanged == Shake.ChangedRecomputeDiff then built else maybe built resultChanged result
         -- only update the deps when the rule ran with changes
-    let actual_deps = if runChanged /= Shake.ChangedNothing then deps else previousDeps
+    let actualDeps = if runChanged /= Shake.ChangedNothing then deps else previousDeps
         previousDeps= resultDeps =<< result
-    let res = Result runValue built changed actual_deps runStore
-    withLock databaseLock $
+    let res = Result runValue built changed actualDeps runStore
+    withLock databaseLock $ do
+        updateReverseDeps id db (fromMaybe [] previousDeps) (fromMaybe [] actualDeps)
         Ids.insert databaseValues id (key, Clean res)
     pure res
 
@@ -152,3 +173,41 @@ splitIO act = do
     let act2 = Box <$> act
     let res = unsafePerformIO act2
     (void $ evaluate res, fromBox res)
+
+--------------------------------------------------------------------------------
+-- Reverse dependencies
+
+-- | Update the reverse dependencies of an Id
+updateReverseDeps
+    :: Id         -- ^ Id
+    -> Database
+    -> [Id] -- ^ Previous direct dependencies of Id
+    -> [Id]       -- ^ Current direct dependencies of Id
+    -> IO ()
+updateReverseDeps myId db prev new = do
+    forM_ prev $ doOne (Set.delete $ idToInt myId)
+    forM_ new  $ doOne (Set.insert $ idToInt myId)
+    where
+        doOne f id = withLock (databaseReverseDepsLock db) $ do
+            rdeps <- getReverseDependencies db id
+            Ids.insert (databaseReverseDeps db) id (f $ fromMaybe mempty rdeps)
+
+idToInt :: Id -> Int
+idToInt = id
+
+getReverseDependencies :: Database -> Id -> IO (Maybe (IntSet))
+getReverseDependencies db = Ids.lookup (databaseReverseDeps db)
+
+transitiveDirtySet :: Foldable t => Database -> t Id -> IO IntSet
+transitiveDirtySet database = flip State.execStateT Set.empty . traverse_ loop
+  where
+    loop (idToInt -> x) = do
+        seen <- State.get
+        if x `Set.member` seen then pure () else do
+            State.put (Set.insert x seen)
+            next <- lift $ getReverseDependencies database x
+            traverse_ loop (maybe mempty Set.toList next)
+
+
+idFromInt :: Set.Key -> Id
+idFromInt = id