Async.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Debug.Brick.Action.Async (
  runWithAsyncSampleReporter,
) where

import Brick.BChan
import Brick.Types
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Exception
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import qualified Data.Text as Text
import Lens.Micro

import GHC.Debug.Async
import GHC.Debug.Brick.Model
import GHC.Debug.Brick.UI.Async
import GHC.Debug.Client

-- | Run the action asynchronously sending update messages periodically
-- to the brick UI.
--
-- After the computation @action@ has finished, a final operation @andThen@ can be executed, for example to update
-- the UI footer, or to persist the results of the heap traversal to disk.
--
-- The update period is configurable via @'OperationalState'.'_asyncSamplingInterval'@.
--
-- @'runWithAsyncSampleReporter' dbg desc mkEvent action andThen@
runWithAsyncSampleReporter :: forall a n . Debuggee -> Text -> (a -> SampleEvent) -> IO (AsyncTrace a) -> (a -> EventM Name OperationalState ()) -> EventM n OperationalState ()
runWithAsyncSampleReporter dbg desc mkEvent action andThen = do
  outside_os <- get
  let
    reportSampleResult :: a -> IO ()
    reportSampleResult a = do
      writeBChan (outside_os ^. event_chan) (NewSampleEvent $ mkEvent a)

    runAsyncAction :: IO a
    runAsyncAction = do
      asyncTrace <- action

      let
        progressReporter = do
          threadDelay (outside_os ^. asyncSamplingInterval)
          asyncResult asyncTrace >>= \ case
            Done a -> reportSampleResult a
            Running a -> reportSampleResult a
            NotStarted -> pure ()
          progressReporter

      mRes <- run dbg (waitForAsyncTraceResultM asyncTrace)
            `race` progressReporter
      case mRes of
        Left finalRes -> pure finalRes
        Right () -> throwIO $ ErrorCall $ Text.unpack desc <> ": progress reporter unexpectedly terminated"

  asyncAction desc runAsyncAction $ \ finalRes -> do
    -- write final result to the IOTree
    liftIO $ reportSampleResult finalRes
    andThen finalRes