fix skipped actions

Author: soulomoon

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

@@ -88,11 +88,7 @@ shakeRunDatabaseForKeysSep
     -> [Action a]
     -> Bool
     -> IO (IO [Either SomeException a])
-shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase _ as1 db) acts isTesting = do
-    let runOne d = do
-            getAction d
-            liftIO $ atomically $ doneQueue d (databaseActionQueue db)
-
+shakeRunDatabaseForKeysSep keysChanged sdb@(ShakeDatabase _ as1 db) acts isTesting = do
     -- we can to upsweep these keys in order one by one,
     preserves <- incDatabase1 db keysChanged
     (_, act) <- instantiateDelayedAction (mkDelayedAction "upsweep" Debug $ upsweepAction)
@@ -101,9 +97,9 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase _ as1 db) acts isTesting =
         if isTesting
         then return $ reenqueued
         else return $ filter (\d -> (newDirectKey $ fromJust $ hashUnique <$> uniqueID d) `notMemberKeySet` preserves) reenqueued
-    let ignoreResultActs = (getAction act) : (liftIO $ prepareToRunKeysRealTime db) : as1 ++ map runOne reenqueuedExceptPreserves
+    let ignoreResultActs = (getAction act) : (liftIO $ prepareToRunKeysRealTime db) : as1
     return $ do
-        -- prepareToRunKeys db upsweepKeys
+        seqRunActions (newKey "root") db $ map (pumpActionThreadReRun sdb) reenqueuedExceptPreserves
         drop (length ignoreResultActs) <$> runActions (newKey "root") db (map unvoid ignoreResultActs ++ acts)
 
 instantiateDelayedAction

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

@@ -15,12 +15,16 @@ module Development.IDE.Graph.Internal.Action
 , getKeysAndVisitedAge
 , isAsyncException
 , pumpActionThread
+, pumpActionThreadReRun
+, sequenceRun
+, seqRunActions
 ) where
 
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM.Stats            (atomicallyNamed)
 import           Control.DeepSeq                         (force)
 import           Control.Exception
+import           Control.Monad                           (void)
 import           Control.Monad.IO.Class
 import           Control.Monad.RWS                       (MonadReader (ask),
                                                           asks)
@@ -77,6 +81,20 @@ parallel xs = do
 --       getAction d
 --       liftIO $ atomically $ doneQueue d actionQueue
 
+-- pumpActionThread1 :: ShakeDatabase -> Action ()
+pumpActionThreadReRun :: ShakeDatabase -> DelayedAction () -> Action ()
+pumpActionThreadReRun (ShakeDatabase _ _ db) d = do
+        a <- ask
+        s <- atomically $ getDataBaseStepInt db
+        liftIO $ runInThreadStmInNewThreads db
+            (return $ DeliverStatus s (actionName d) key)
+            (ignoreState a $ runOne d) (const $ return ())
+  where
+    key = (newDirectKey $ fromJust $ hashUnique <$> uniqueID d)
+    runOne d = setActionKey key $ do
+            _ <- getAction d
+            liftIO $ atomically $ doneQueue d (databaseActionQueue db)
+
 pumpActionThread :: ShakeDatabase -> (String -> IO ()) -> Action b
 pumpActionThread sdb@(ShakeDatabase _ _ db) logMsg = do
     do
@@ -177,7 +195,18 @@ runActions pk db xs = do
     deps <- newIORef mempty
     runActionMonad (parallel xs) $ SAction pk db deps emptyStack
 
--- | Returns the set of dirty keys annotated with their age (in # of builds)
+seqRunActions :: Key -> Database -> [Action a] -> IO ()
+seqRunActions pk db xs = do
+    deps <- newIORef mempty
+    runActionMonad (sequenceRun xs) $ SAction pk db deps emptyStack
+
+sequenceRun :: [Action a] -> Action ()
+sequenceRun [] = return ()
+sequenceRun (x:xs) = do
+    void x
+    sequenceRun xs
+
+-- | Returns the set of dirty keys annotated with their age
 getDirtySet  :: Action [(Key, Int)]
 getDirtySet = do
     db <- getDatabase