remove running wait

Author: soulomoon

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

@@ -100,7 +100,7 @@ computeToPreserve db dirtySet = do
 updateDirty :: Monad m => Focus.Focus KeyDetails m ()
 updateDirty = Focus.adjust $ \(KeyDetails status rdeps) ->
             let status'
-                  | Running _ x _ <- status = Dirty x
+                  | Running _ x <- status = Dirty x
                   | Clean x <- status = Dirty (Just x)
                   | otherwise = status
             in KeyDetails status' rdeps
@@ -156,7 +156,6 @@ data FirstTime = FirstTime | NotFirstTime
 builderOne' :: FirstTime -> Key -> Database -> Stack -> Key -> IO BuildContinue
 builderOne' firstTime parentKey db@Database {..} stack kid = do
   traceEvent ("builderOne: " ++ show kid) return ()
-  barrier <- newEmptyMVar
   -- join is used to register the async
   join $ atomicallyNamed "builder" $ do
     -- Spawn the id if needed
@@ -167,23 +166,28 @@ builderOne' firstTime parentKey db@Database {..} stack kid = do
         NotFirstTime -> return ()
     status <- SMap.lookup kid databaseValues
     current <- readTVar databaseStep
+    let revisit =
+            case firstTime of
+                FirstTime -> pure . pure $ BCContinue $ do
+                        br <- builderOne' NotFirstTime parentKey db stack kid
+                        case br of
+                            BCContinue ioR -> ioR
+                            BCStop k r     -> pure $ Right (k, r)
+                NotFirstTime -> retry
     case (viewToRun current . keyStatus) =<< status of
       Nothing -> do
-        SMap.focus (updateStatus $ Running current Nothing barrier) kid databaseValues
-        let register = spawnRefresh1 db stack kid barrier Nothing refresh
-                        $ atomicallyNamed "builderOne rollback" $ SMap.delete kid databaseValues
-        return $ register >> return (BCContinue $ readMVar barrier)
-      Just (Dirty _) -> case firstTime of
-        FirstTime -> pure . pure $ BCContinue $ do
-                br <- builderOne' NotFirstTime parentKey db stack kid
-                case br of
-                    BCContinue ioR -> ioR
-                    BCStop k r     -> pure $ Right (k, r)
-        NotFirstTime -> retry
-      Just (Clean r) -> pure . pure $ BCStop kid r
-      Just (Running _step _s wait)
+        SMap.focus (updateStatus $ Running current Nothing) kid databaseValues
+        let register barrier = do
+                spawnRefresh1 db stack kid barrier Nothing refresh
+                            $ atomicallyNamed "builderOne rollback" $ SMap.delete kid databaseValues
+        return $ do
+             barrier <- newEmptyMVar
+             register barrier >> return (BCContinue $ readMVar barrier)
+      Just (Dirty _) -> revisit
+      Just (Running _step _s)
         | memberStack kid stack -> throw $ StackException stack
-        | otherwise -> pure . pure $ BCContinue $ readMVar wait
+        | otherwise -> revisit
+      Just (Clean r) -> pure . pure $ BCStop kid r
 
 -- Original spawnRefresh1 implementation moved below to use the abstraction
 
@@ -248,7 +252,7 @@ upSweep db@Database {..} stack key childtKey = mask $ \restore -> do
     case viewDirty current $ maybe (Dirty Nothing) keyStatus status of
       -- if it is still dirty, we update it and propogate further
       (Dirty s) -> do
-        SMap.focus (updateStatus $ Running current s barrier) key databaseValues
+        SMap.focus (updateStatus $ Running current s) key databaseValues
         -- if it is clean, other event update it, so it is fine.
         return $ spawnRefresh1 db stack key barrier s (\db stack key s -> restore $ do
           result <- refresh db stack key s

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

@@ -477,8 +477,7 @@ data Status
     | Running {
         runningStep :: !Step,
         -- runningResult :: Result,     -- LAZY
-        runningPrev :: !(Maybe Result),
-        runningWait :: !(MVar (Either SomeException (Key, Result)))
+        runningPrev :: !(Maybe Result)
         }
 
 viewDirty :: Step -> Status -> Status
@@ -492,9 +491,9 @@ viewToRun :: Step -> Status -> Maybe Status
 viewToRun _ other = Just other
 
 getResult :: Status -> Maybe Result
-getResult (Clean re)         = Just re
-getResult (Dirty m_re)       = m_re
-getResult (Running _ m_re _) = m_re -- watch out: this returns the previous result
+getResult (Clean re)       = Just re
+getResult (Dirty m_re)     = m_re
+getResult (Running _ m_re) = m_re -- watch out: this returns the previous result
 
 
 data Result = Result {