Fix reverse dep. tracking for alwaysRerun rules

When I ported reverse dependencies from Shake[1] I missed an important
detail. While Shake models alwaysRerun as a dependency on an actual rule
(AlwaysRerun), hls-graph models alwaysRerun by setting actionDeps to
Nothing. This is important because dependencies are not computed for
these rules, and therefore reverse dependency tracking doesn't do
anything, which breaks correctness of dirty rebuilds

This commit adds dependency tracking for alwaysRerun rules, and fixes
reverse dependency tracking. The alternative would be following the
Shake approach but I'm not sure what other implications this might have.

[1] - ndmitchell/shake#802

Author: pepeiborra

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

@@ -1,7 +1,7 @@
+{-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE ConstraintKinds #-}
 
 module Development.IDE.Graph.Internal.Action
 ( ShakeValue
@@ -19,23 +19,23 @@ module Development.IDE.Graph.Internal.Action
 
 import           Control.Concurrent.Async
 import           Control.Exception
-import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Reader
 import           Data.IORef
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Database
+import           Development.IDE.Graph.Internal.Rules    (RuleResult)
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
-import Development.IDE.Graph.Internal.Rules (RuleResult)
 
 type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 
+-- | Always rerun this rule when dirty, regardless of the dependencies.
 alwaysRerun :: Action ()
 alwaysRerun = do
     ref <- Action $ asks actionDeps
-    liftIO $ writeIORef ref Nothing
+    liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
 
 -- No-op for now
 reschedule :: Double -> Action ()
@@ -48,23 +48,23 @@ parallel xs = do
     a <- Action ask
     deps <- liftIO $ readIORef $ actionDeps a
     case deps of
-        Nothing ->
+        UnknownDeps ->
             -- if we are already in the rerun mode, nothing we do is going to impact our state
             liftIO $ mapConcurrently (ignoreState a) xs
-        Just deps -> do
+        deps -> do
             (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
-            liftIO $ writeIORef (actionDeps a) $ (deps ++) <$> concatMapM id newDeps
+            liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
             pure res
     where
         usingState a x = do
-            ref <- newIORef $ Just []
+            ref <- newIORef mempty
             res <- runReaderT (fromAction x) a{actionDeps=ref}
             deps <- readIORef ref
             pure (deps, res)
 
 ignoreState :: SAction -> Action b -> IO b
 ignoreState a x = do
-    ref <- newIORef Nothing
+    ref <- newIORef mempty
     runReaderT (fromAction x) a{actionDeps=ref}
 
 actionFork :: Action a -> (Async a -> Action b) -> Action b
@@ -73,7 +73,7 @@ actionFork act k = do
     deps <- liftIO $ readIORef $ actionDeps a
     let db = actionDatabase a
     case deps of
-        Nothing -> do
+        UnknownDeps -> do
             -- if we are already in the rerun mode, nothing we do is going to impact our state
             [res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as]
             return res
@@ -116,12 +116,10 @@ apply ks = do
     db <- Action $ asks actionDatabase
     (is, vs) <- liftIO $ build db ks
     ref <- Action $ asks actionDeps
-    deps <- liftIO $ readIORef ref
-    whenJust deps $ \deps ->
-        liftIO $ writeIORef ref $ Just $ is ++ deps
+    liftIO $ modifyIORef ref (ResultDeps is <>)
     pure vs
 
 runActions :: Database -> [Action a] -> IO [a]
 runActions db xs = do
-    deps <- newIORef Nothing
+    deps <- newIORef mempty
     runReaderT (fromAction $ parallel xs) $ SAction db deps

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

@@ -135,7 +135,7 @@ builder db@Database{..} keys = do
 --       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 -> Key -> Id -> Maybe Result -> AIO (IO Result)
-refresh db key id result@(Just me@Result{resultDeps=Just deps}) = do
+refresh db key id result@(Just me@Result{resultDeps = ResultDeps deps}) = do
     res <- builder db $ map Left deps
     case res of
       Left res ->
@@ -157,7 +157,7 @@ refresh db key id result =
 compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result
 compute db@Database{..} key id mode result = do
     let act = runRule databaseRules key (fmap resultData result) mode
-    deps <- newIORef $ Just []
+    deps <- newIORef UnknownDeps
     (execution, RunResult{..}) <-
         duration $ runReaderT (fromAction act) $ SAction db deps
     built <- readIORef databaseStep
@@ -166,14 +166,14 @@ compute db@Database{..} key id mode result = do
         built' = if runChanged /= ChangedNothing then built else changed
         -- only update the deps when the rule ran with changes
         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
-        previousDeps= resultDeps =<< result
+        previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
     case actualDeps of
-        Just deps | not(null deps) &&
+        ResultDeps deps | not(null deps) &&
                     runChanged /= ChangedNothing
                     -> do
             void $ forkIO $
-                updateReverseDeps id db (fromMaybe [] previousDeps) (Set.fromList deps)
+                updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)
         _ -> pure ()
     withLock databaseLock $
         Ids.insert databaseValues id (key, Clean res)

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

@@ -61,7 +61,7 @@ data ProfileEntry = ProfileEntry
 -- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value))
 resultsOnly :: [(Ids.Id, (k, Status))] -> Map.HashMap Ids.Id (k, Result)
 resultsOnly mp = Map.map (fmap (\r ->
-      r{resultDeps = fmap (filter (isJust . flip Map.lookup keep)) $ resultDeps r}
+      r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r}
     )) keep
     where
         keep = Map.fromList $ mapMaybe ((traverse.traverse) getResult) mp
@@ -113,7 +113,7 @@ toReport db = do
     status <- prepareForDependencyOrder db
     let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status
                 in dependencyOrder shw
-                $ map (second (fromMaybe [-1] . resultDeps . snd))
+                $ map (second (getResultDepsDefault [-1] . resultDeps . snd))
                 $ Map.toList status
         ids = IntMap.fromList $ zip order [0..]
 
@@ -126,14 +126,14 @@ toReport db = do
             ,prfBuilt = fromStep resultBuilt
             ,prfVisited = fromStep resultVisited
             ,prfChanged = fromStep resultChanged
-            ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ fromMaybe [-1] $ resultDeps
+            ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ getResultDepsDefault [-1] resultDeps
             ,prfExecution = resultExecution
             }
             where fromStep i = fromJust $ Map.lookup i steps
     pure ([maybe (error "toReport") f $ Map.lookup i status | i <- order], ids)
 
 alwaysRerunResult :: Step -> Result
-alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (Just []) 0 mempty
+alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps []) 0 mempty
 
 readDataFileHTML :: FilePath -> IO LBS.ByteString
 readDataFileHTML file = LBS.readFile =<< getDataFile ("html" </> file)

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

@@ -55,7 +55,7 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a}
 
 data SAction = SAction {
     actionDatabase :: !Database,
-    actionDeps     :: !(IORef (Maybe [Id])) -- Nothing means always rerun
+    actionDeps     :: !(IORef ResultDeps)
     }
 
 
@@ -105,11 +105,33 @@ data Result = Result {
     resultBuilt     :: !Step, -- ^ the step when it was last recomputed
     resultChanged   :: !Step, -- ^ the step when it last changed
     resultVisited   :: !Step, -- ^ the step when it was last looked up
-    resultDeps      :: !(Maybe [Id]), -- ^ Nothing = alwaysRerun
+    resultDeps      :: !ResultDeps,
     resultExecution :: !Seconds, -- ^ How long it took, last time it ran
     resultData      :: BS.ByteString
     }
 
+data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Id] | ResultDeps ![Id]
+
+getResultDepsDefault :: [Id] -> ResultDeps -> [Id]
+getResultDepsDefault _ (ResultDeps ids)      = ids
+getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
+getResultDepsDefault def UnknownDeps         = def
+
+mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps
+mapResultDeps f (ResultDeps ids)      = ResultDeps $ f ids
+mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
+mapResultDeps _ UnknownDeps           = UnknownDeps
+
+instance Semigroup ResultDeps where
+    UnknownDeps <> x = x
+    x <> UnknownDeps = x
+    AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x)
+    x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids)
+    ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')
+
+instance Monoid ResultDeps where
+    mempty = UnknownDeps
+
 ---------------------------------------------------------------------
 -- Running builds