cleanup

Author: soulomoon

.github/workflows/flakiness.yml

@@ -81,7 +81,6 @@ actionFork act k = do
 
 isAsyncException :: SomeException -> Bool
 isAsyncException e
-    | Just (_ :: SomeAsyncException) <- fromException e = True
     | Just (_ :: AsyncCancelled) <- fromException e = True
     | Just (_ :: AsyncException) <- fromException e = True
     | Just (_ :: ExitCode) <- fromException e = True

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

@@ -17,7 +17,7 @@ import           Control.Concurrent.Extra
 import           Control.Concurrent.STM.Stats         (STM, atomically,
                                                        atomicallyNamed,
                                                        modifyTVar', newTVarIO,
-                                                       readTVarIO, retry)
+                                                       readTMVar, readTVarIO)
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.IO.Class               (MonadIO (liftIO))
@@ -39,7 +39,8 @@ import qualified Focus
 import qualified ListT
 import qualified StmContainers.Map                    as SMap
 import           System.Time.Extra                    (duration, sleep)
-import           UnliftIO                             (MonadUnliftIO (withRunInIO))
+import           UnliftIO                             (MonadUnliftIO (withRunInIO),
+                                                       newEmptyTMVarIO)
 import qualified UnliftIO.Exception                   as UE
 
 #if MIN_VERSION_base(4,19,0)
@@ -78,7 +79,7 @@ incDatabase db Nothing = 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
@@ -112,6 +113,7 @@ builder db stack keys = do
 builderOne :: BuildArity -> Database -> Stack -> Key -> AIO (Key, IO Result)
 builderOne ba db@Database {..} stack id = UE.mask $ \restore -> do
   current <- liftIO $ readTVarIO databaseStep
+  barrier <- newEmptyTMVarIO
   (k, registerWaitResult) <- liftIO $ atomicallyNamed "builder" $ do
     -- Spawn the id if needed
     status <- SMap.lookup id databaseValues
@@ -124,14 +126,14 @@ builderOne ba db@Database {..} stack id = UE.mask $ \restore -> do
                         `UE.onException` (UE.uninterruptibleMask_ $ liftIO (atomicallyNamed "builder - onException" (SMap.focus updateDirty id databaseValues)))
                   BuildUnary -> fmap return $ refresh db stack id s
             -- Mark the key as running
-            SMap.focus (updateStatus $ Running current s) id databaseValues
+            SMap.focus (updateStatus $ Running current (atomically $ readTMVar barrier) s) id databaseValues
             return act
        in case viewDirty current $ maybe (Dirty Nothing) keyStatus status of
             Dirty mbr -> refreshRsult mbr
-            Running step _mbr
+            Running step ba _mbr
               | step /= current -> error $ "Inconsistent database state: key " ++ show id ++ " is marked Running at step " ++ show step ++ " but current step is " ++ show current
               | memberStack id stack -> throw $ StackException stack
-              | otherwise -> retry
+              | otherwise -> pure . pure $ ba
             Clean r -> pure . pure . pure $ r
     -- force here might contains async exceptions from previous runs
     pure (id, val)

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

@@ -6,6 +6,7 @@
 module Development.IDE.Graph.Internal.Types where
 
 import           Control.Concurrent.STM             (STM)
+import           Control.Monad                      (void, (>=>))
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Reader
@@ -79,8 +80,8 @@ getDatabase :: Action Database
 getDatabase = Action $ asks actionDatabase
 
 -- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running.
--- waitForDatabaseRunningKeysAction :: Action ()
--- waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys
+waitForDatabaseRunningKeysAction :: Action ()
+waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys
 
 ---------------------------------------------------------------------
 -- DATABASE
@@ -112,12 +113,10 @@ data Database = Database {
     databaseRules  :: TheRules,
     databaseStep   :: !(TVar Step),
     databaseValues :: !(Map Key KeyDetails)
-    -- ^ The set of dirty keys, which are the keys that have been marked as dirty
-    -- by the client, it would be removed once the target key is marked as clean.
     }
 
--- waitForDatabaseRunningKeys :: Database -> IO ()
--- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd)
+waitForDatabaseRunningKeys :: Database -> IO ()
+waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd)
 
 getDatabaseValues :: Database -> IO [(Key, Status)]
 getDatabaseValues = atomically
@@ -131,19 +130,23 @@ data Status
     | Dirty (Maybe Result)
     | Running {
         runningStep :: !Step,
-        -- runningWait   :: !(IO ()),
+        runningWait :: !(IO Result),
         -- runningResult :: Result,     -- LAZY
         runningPrev :: !(Maybe Result)
         }
 
 viewDirty :: Step -> Status -> Status
-viewDirty currentStep (Running s re) | currentStep /= s = Dirty re
+viewDirty currentStep (Running s _ re) | currentStep /= s = Dirty re
 viewDirty _ other = 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
+
+waitRunning :: Status -> IO ()
+waitRunning Running{..} = void runningWait
+waitRunning _           = return ()
 
 data Result = Result {
     resultValue     :: !Value,