Async.hs

{-# LANGUAGE BangPatterns #-}
module GHC.Debug.Brick.UI.Async where

import Brick
import Brick.BChan
import Control.Concurrent.Async
import Control.Monad.IO.Class
import Data.Text (Text)
import Data.Time.Clock
import GHC.Debug.Brick.Model
import Lens.Micro.Platform
import qualified Control.Exception.Safe as Safe

asyncAction_ :: Text -> IO a -> EventM n OperationalState ()
asyncAction_ desc  action = asyncAction desc action (\_ -> return ())

-- | Abort the currently 'running_task', if there is any, and
-- set the given 'ThreadId' as the new running task.
--
-- This is important to avoid hanging threads and zombies.
setPendingTask :: Async () -> EventM n OperationalState ()
setPendingTask task = do
  os <- get
  case os ^. running_task of
    Just oldTask -> liftIO $ cancel oldTask
    Nothing -> pure ()
  put $ os & running_task .~ Just task

asyncAction :: Text -> IO a -> (a -> EventM Name OperationalState ()) -> EventM n OperationalState ()
asyncAction desc action final = do
  eventChan <- view event_chan <$> get
  task <- liftIO $ async (actionWithProgressReporter eventChan)
  setPendingTask task
  where
    actionWithProgressReporter eventChan = do
      writeBChan eventChan (ProgressMessage desc)
      start <- getCurrentTime
      !res <- Safe.try action
      end <- getCurrentTime

      case res of
        Left exc -> do
          writeBChan eventChan (AsyncAborted exc)
        Right result -> do
          writeBChan eventChan (AsyncFinished (final result))
          writeBChan eventChan (ProgressFinished desc (end `diffUTCTime` start))