recover AlwaysRerunDeps

Author: soulomoon

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

@@ -78,7 +78,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int
 shakeGetBuildEdges (ShakeDatabase _ _ db) = do
     keys <- getDatabaseValues db
     let ress = mapMaybe (getResult . snd) keys
-    return $ sum $ map (lengthKeySet . fold . getResultDepsDefault mempty . resultDeps) ress
+    return $ sum $ map (lengthKeySet . getResultDepsDefault mempty . resultDeps) ress
 
 -- | Returns an approximation of the database keys,
 --   annotated with how long ago (in # builds) they were visited

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

@@ -187,7 +187,7 @@ compute db@Database{..} stack key mode result = do
         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
         previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
-    case fold $ getResultDepsDefault mempty actualDeps of
+    case getResultDepsDefault mempty actualDeps of
         deps | not (nullKeySet deps)
             && runChanged /= ChangedNothing
                     -> do
@@ -197,7 +197,7 @@ compute db@Database{..} stack key mode result = do
             -- on the next build.
             void $
                 updateReverseDeps key db
-                    (fold $ getResultDepsDefault mempty previousDeps)
+                    (getResultDepsDefault mempty previousDeps)
                     deps
         _ -> pure ()
     atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues

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

@@ -109,7 +109,7 @@ toReport :: Database -> IO ([ProfileEntry], KeyMap Int)
 toReport db = do
     status <- prepareForDependencyOrder db
     let order = dependencyOrder show
-                $ map (second (toListKeySet . fold . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps))
+                $ map (second (toListKeySet . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps))
                 $ toListKeyMap status
         ids = fromListKeyMap $ zip order [0..]
 
@@ -122,7 +122,7 @@ toReport db = do
             ,prfBuilt = fromStep resultBuilt
             ,prfVisited = fromStep resultVisited
             ,prfChanged = fromStep resultChanged
-            ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ fold $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps
+            ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps
             ,prfExecution = resultExecution
             }
             where fromStep i = fromJust $ Map.lookup i steps

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,17 +145,20 @@ data Result = Result {
     resultData      :: !BS.ByteString
     }
 
-data ResultDeps = UnknownDeps | AlwaysRerunDeps ![KeySet] | ResultDeps ![KeySet]
+-- some invariant to maintain:
+-- the ResultDeps need to be stored in reverse order,
+-- so that we can append to it efficiently
+data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet]
   deriving (Eq, Show)
 
-getResultDepsDefault :: KeySet -> ResultDeps -> [KeySet]
-getResultDepsDefault _ (ResultDeps ids)      = ids
+getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
+getResultDepsDefault _ (ResultDeps ids)      = fold ids
 getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
-getResultDepsDefault def UnknownDeps         = [def]
+getResultDepsDefault def UnknownDeps         = def
 
 mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
 mapResultDeps f (ResultDeps ids)      = ResultDeps $ fmap f ids
-mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ fmap f ids
+mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
 mapResultDeps _ UnknownDeps           = UnknownDeps
 
 instance Semigroup ResultDeps where