diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 8f67b83a9..c70cf6ff1 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -6,6 +6,7 @@ module Development.IDE.Graph.Internal.Types where import Control.Concurrent.STM (STM) +import Control.Monad ((>=>)) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -78,6 +79,10 @@ data SAction = SAction { getDatabase :: Action Database getDatabase = Action $ asks actionDatabase +-- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running. +waitForDatabaseRunningKeysAction :: Action () +waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys + --------------------------------------------------------------------- -- DATABASE @@ -110,6 +115,9 @@ data Database = Database { databaseValues :: !(Map Key KeyDetails) } +waitForDatabaseRunningKeys :: Database -> IO () +waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) + getDatabaseValues :: Database -> IO [(Key, Status)] getDatabaseValues = atomically . (fmap.fmap) (second keyStatus) @@ -136,6 +144,10 @@ 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{..} = runningWait +waitRunning _ = return () + data Result = Result { resultValue :: !Value, resultBuilt :: !Step, -- ^ the step when it was last recomputed