API changes: get rid of InternalSuspendAndResume, make suspendAndResume immediate

This change refactors the internal book-keeping for the Vty context (Vty handle, event forwarding thread, and Vty builder) so that we could get rid of the InternalHalt / InternalSuspendAndResume mess. This change also made suspendAndResume immediate rather than deferring the suspension of Vty until after the event handler terminated. This may have important consequences for applications that assumed the function was not immediate. Now, it will *immediately* shut down the Vty context and execute the specified action. This leads to a more natural and sane behavior. This change also introduced a more generic "Brick.Main.suspendAndResume'" function that can execute any IO action and return its result, which is useful when you want to do some work that has nothing specifically to do with the EventM state type.
2024-12-28 16:34:45 +03:00 · 2022-07-26 19:03:47 -07:00 · 2022-07-26 19:03:47 -07:00 · e0c70f070a
commit e0c70f070a
parent 0b6b562821
4 changed files with 121 additions and 72 deletions
--- a/src/Brick/Main.hs
+++ b/src/Brick/Main.hs
@ -13,6 +13,7 @@ module Brick.Main
  , continueWithoutRedraw
  , halt
  , suspendAndResume
+  , suspendAndResume'
  , makeVisible
  , lookupViewport
  , lookupExtent
@ -171,41 +172,35 @@ resizeOrQuit :: BrickEvent n e -> EventM n s ()
 resizeOrQuit (VtyEvent (EvResize _ _)) = return ()
 resizeOrQuit _ = halt

-data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a)
-                      | InternalHalt a
-
 readBrickEvent :: BChan (BrickEvent n e) -> BChan e -> IO (BrickEvent n e)
 readBrickEvent brickChan userChan = either id AppEvent <$> readBChan2 brickChan userChan

 runWithVty :: (Ord n)
-           => Vty
+           => VtyContext
           -> BChan (BrickEvent n e)
           -> Maybe (BChan e)
           -> App s e n
           -> RenderState n
           -> s
-           -> IO (InternalNext n s)
-runWithVty vty brickChan mUserChan app initialRS initialSt = do
-    pid <- forkIO $ supplyVtyEvents vty brickChan
+           -> IO (s, VtyContext)
+runWithVty vtyCtx brickChan mUserChan app initialRS initialSt = do
    let readEvent = case mUserChan of
          Nothing -> readBChan brickChan
          Just uc -> readBrickEvent brickChan uc
-        runInner rs es draw st = do
+        runInner ctx rs es draw st = do
          let nextRS = if draw
                       then resetRenderState rs
                       else rs
-          (nextSt, result, newRS, newExtents) <- runVty vty readEvent app st nextRS es draw
+          (nextSt, result, newRS, newExtents, newCtx) <- runVty ctx readEvent app st nextRS es draw
          case result of
-              SuspendAndResume act -> do
-                  killThread pid
-                  return $ InternalSuspendAndResume newRS act
-              Halt -> do
-                  killThread pid
-                  return $ InternalHalt nextSt
-              Continue -> runInner newRS newExtents True nextSt
+              Halt ->
+                  return (nextSt, newCtx)
+              Continue ->
+                  runInner newCtx newRS newExtents True nextSt
              ContinueWithoutRedraw ->
-                  runInner newRS newExtents False nextSt
-    runInner initialRS mempty True initialSt
+                  runInner newCtx newRS newExtents False nextSt
+
+    runInner vtyCtx initialRS mempty True initialSt

 -- | The custom event loop entry point to use when the simpler ones
 -- don't permit enough control. Returns the final application state
@ -265,20 +260,18 @@ customMainWithVty :: (Ord n)
                  -- ^ The initial application state.
                  -> IO (s, Vty)
 customMainWithVty initialVty buildVty mUserChan app initialAppState = do
-    let run vty rs st brickChan = do
-            result <- runWithVty vty brickChan mUserChan app rs st
-                `E.catch` (\(e::E.SomeException) -> shutdown vty >> E.throw e)
-            case result of
-                InternalHalt s -> return (s, vty)
-                InternalSuspendAndResume newRS action -> do
-                    shutdown vty
-                    newAppState <- action
-                    newVty <- buildVty
-                    run newVty (newRS { renderCache = mempty }) newAppState brickChan
+    brickChan <- newBChan 20
+    vtyCtx <- newVtyContext buildVty (Just initialVty) (writeBChan brickChan . VtyEvent)

-    let emptyES = ES [] mempty mempty initialAppState Continue
+    let emptyES = ES { esScrollRequests = []
+                     , cacheInvalidateRequests = mempty
+                     , requestedVisibleNames = mempty
+                     , applicationState = initialAppState
+                     , nextAction = Continue
+                     , vtyContext = vtyCtx
+                     }
        emptyRS = RS M.empty mempty S.empty mempty mempty mempty mempty
-        eventRO = EventRO M.empty initialVty mempty emptyRS
+        eventRO = EventRO M.empty mempty emptyRS

    ((), eState) <- runStateT (runReaderT (runEventM (appStartEvent app)) eventRO) emptyES
    let initialRS = RS { viewportMap = M.empty
@ -289,27 +282,57 @@ customMainWithVty initialVty buildVty mUserChan app initialAppState = do
                       , requestedVisibleNames_ = requestedVisibleNames eState
                       , reportedExtents = mempty
                       }
-    brickChan <- newBChan 20
-    run initialVty initialRS (applicationState eState) brickChan

-supplyVtyEvents :: Vty -> BChan (BrickEvent n e) -> IO ()
-supplyVtyEvents vty chan =
-    forever $ do
-        e <- nextEvent vty
-        writeBChan chan $ VtyEvent e
+    (s, ctx) <- runWithVty vtyCtx brickChan mUserChan app initialRS (applicationState eState)
+                `E.catch` (\(e::E.SomeException) -> shutdownVtyContext vtyCtx >> E.throw e)
+
+    -- Shut down the context's event thread but do NOT shut down Vty
+    -- itself because we want the handle to be live when we return it to
+    -- the caller.
+    shutdownVtyContextThread ctx
+    return (s, vtyContextHandle ctx)
+
+supplyVtyEvents :: Vty -> (Event -> IO ()) -> IO ()
+supplyVtyEvents vty putEvent =
+    forever $ putEvent =<< nextEvent vty
+
+newVtyContextFrom :: VtyContext -> IO VtyContext
+newVtyContextFrom old =
+    newVtyContext (vtyContextBuilder old) Nothing (vtyContextPutEvent old)
+
+newVtyContext :: IO Vty -> Maybe Vty -> (Event -> IO ()) -> IO VtyContext
+newVtyContext builder handle putEvent = do
+    vty <- case handle of
+        Just h -> return h
+        Nothing -> builder
+    tId <- forkIO $ supplyVtyEvents vty putEvent
+    return VtyContext { vtyContextHandle = vty
+                      , vtyContextBuilder = builder
+                      , vtyContextThread = tId
+                      , vtyContextPutEvent = putEvent
+                      }
+
+shutdownVtyContext :: VtyContext -> IO ()
+shutdownVtyContext ctx = do
+    shutdown $ vtyContextHandle ctx
+    shutdownVtyContextThread ctx
+
+shutdownVtyContextThread :: VtyContext -> IO ()
+shutdownVtyContextThread ctx =
+    killThread $ vtyContextThread ctx

 runVty :: (Ord n)
-       => Vty
+       => VtyContext
       -> IO (BrickEvent n e)
       -> App s e n
       -> s
       -> RenderState n
       -> [Extent n]
       -> Bool
-       -> IO (s, NextAction s, RenderState n, [Extent n])
-runVty vty readEvent app appState rs prevExtents draw = do
+       -> IO (s, NextAction, RenderState n, [Extent n], VtyContext)
+runVty vtyCtx readEvent app appState rs prevExtents draw = do
    (firstRS, exts) <- if draw
-                       then renderApp vty app appState rs
+                       then renderApp vtyCtx app appState rs
                       else return (rs, prevExtents)

    e <- readEvent
@ -320,7 +343,7 @@ runVty vty readEvent app appState rs prevExtents draw = do
        -- want the event handler to have access to accurate viewport
        -- information.
        VtyEvent (EvResize _ _) -> do
-            (rs', exts') <- renderApp vty app appState $ firstRS & observedNamesL .~ S.empty
+            (rs', exts') <- renderApp vtyCtx app appState $ firstRS & observedNamesL .~ S.empty
            return (e, rs', exts')
        VtyEvent (EvMouseDown c r button mods) -> do
            let matching = findClickedExtents_ (c, r) exts
@ -372,8 +395,8 @@ runVty vty readEvent app appState rs prevExtents draw = do
                _ -> return (e, firstRS, exts)
        _ -> return (e, firstRS, exts)

-    let emptyES = ES [] mempty mempty appState Continue
-        eventRO = EventRO (viewportMap nextRS) vty nextExts nextRS
+    let emptyES = ES [] mempty mempty appState Continue vtyCtx
+        eventRO = EventRO (viewportMap nextRS) nextExts nextRS

    ((), eState) <- runStateT (runReaderT (runEventM (appHandleEvent app e'))
                                eventRO) emptyES
@ -385,6 +408,7 @@ runVty vty readEvent app appState rs prevExtents draw = do
                    , requestedVisibleNames_ = requestedVisibleNames eState
                    }
           , nextExts
+           , vtyContext eState
           )

 applyInvalidations :: (Ord n) => S.Set (CacheInvalidateRequest n) -> M.Map n v -> M.Map n v
@ -439,7 +463,11 @@ findClickedExtents_ pos = reverse . filter (clickedExtent pos)

 -- | Get the Vty handle currently in use.
 getVtyHandle :: EventM n s Vty
-getVtyHandle = EventM $ asks eventVtyHandle
+getVtyHandle = vtyContextHandle <$> getVtyContext
+
+setVtyContext :: VtyContext -> EventM n s ()
+setVtyContext ctx =
+    EventM $ lift $ modify $ \s -> s { vtyContext = ctx }

 -- | Invalidate the rendering cache entry with the specified resource
 -- name.
@ -460,9 +488,9 @@ resetRenderState s =
    s & observedNamesL .~ S.empty
      & clickableNamesL .~ mempty

-renderApp :: (Ord n) => Vty -> App s e n -> s -> RenderState n -> IO (RenderState n, [Extent n])
-renderApp vty app appState rs = do
-    sz <- displayBounds $ outputIface vty
+renderApp :: (Ord n) => VtyContext -> App s e n -> s -> RenderState n -> IO (RenderState n, [Extent n])
+renderApp vtyCtx app appState rs = do
+    sz <- displayBounds $ outputIface $ vtyContextHandle vtyCtx
    let (newRS, pic, theCursor, exts) = renderFinal (appAttrMap app appState)
                                        (appDraw app appState)
                                        sz
@ -477,7 +505,7 @@ renderApp vty app appState rs = do
                                           (cloc^.locationRowL)
                             }

-    update vty picWithCursor
+    update (vtyContextHandle vtyCtx) picWithCursor

    return (newRS, exts)

@ -577,16 +605,34 @@ halt =

 -- | Suspend the event loop, save the terminal state, and run the
 -- specified action. When it returns an application state value, restore
-- the terminal state, empty the rendering cache, redraw the application
-- from the new state, and resume the event loop.
+-- the terminal state, empty the rendering cache, update the application
+-- state with the returned state, and continue execution of the event
+-- handler that called this.
 --
 -- Note that any changes made to the terminal's input state are ignored
 -- when Brick resumes execution and are not preserved in the final
 -- terminal input state after the Brick application returns the terminal
 -- to the user.
-suspendAndResume :: IO s -> EventM n s ()
-suspendAndResume act =
-    EventM $ lift $ modify $ \es -> es { nextAction = SuspendAndResume act }
+suspendAndResume :: (Ord n) => IO s -> EventM n s ()
+suspendAndResume act = suspendAndResume' act >>= put
+
+-- | Suspend the event loop, save the terminal state, and run the
+-- specified action. When it completes, restore the terminal state,
+-- empty the rendering cache, return the result, and continue execution
+-- of the event handler that called this.
+--
+-- Note that any changes made to the terminal's input state are ignored
+-- when Brick resumes execution and are not preserved in the final
+-- terminal input state after the Brick application returns the terminal
+-- to the user.
+suspendAndResume' :: (Ord n) => IO a -> EventM n s a
+suspendAndResume' act = do
+    ctx <- getVtyContext
+    liftIO $ shutdownVtyContext ctx
+    result <- liftIO act
+    setVtyContext =<< (liftIO $ newVtyContextFrom ctx)
+    invalidateCache
+    return result

 -- | Request that the specified UI element be made visible on the
 -- next rendering. This is provided to allow event handlers to make
--- a/src/Brick/Types.hs
+++ b/src/Brick/Types.hs
@ -134,31 +134,23 @@ nestEventM :: a
 nestEventM s' act = do
    ro <- EventM ask
    s <- EventM $ lift get
+    vtyCtx <- getVtyContext
    let stInner = ES { applicationState = s'
                     , nextAction = Continue
                     , esScrollRequests = esScrollRequests s
                     , cacheInvalidateRequests = cacheInvalidateRequests s
                     , requestedVisibleNames = requestedVisibleNames s
+                     , vtyContext = vtyCtx
                     }
    (actResult, stInnerFinal) <- liftIO $ runStateT (runReaderT (runEventM act) ro) stInner

-    (nextAct, finalSt) <- case nextAction stInnerFinal of
-        Continue ->
-            return (Continue, applicationState stInnerFinal)
-        ContinueWithoutRedraw ->
-            return (ContinueWithoutRedraw, applicationState stInnerFinal)
-        Halt ->
-            return (Halt, applicationState stInnerFinal)
-        SuspendAndResume act' -> do
-            s'' <- liftIO act'
-            return (Continue, s'')
-
-    EventM $ lift $ modify $ \st -> st { nextAction = nextAct
+    EventM $ lift $ modify $ \st -> st { nextAction = nextAction stInnerFinal
                                       , esScrollRequests = esScrollRequests stInnerFinal
                                       , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal
                                       , requestedVisibleNames = requestedVisibleNames stInnerFinal
+                                       , vtyContext = vtyContext stInnerFinal
                                       }
-    return (finalSt, actResult)
+    return (applicationState stInnerFinal, actResult)

 -- | Given a lens into a field of the current state, focus mutations on
 -- the state field itself.
--- a/src/Brick/Types/EventM.hs
+++ b/src/Brick/Types/EventM.hs
@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 module Brick.Types.EventM
  ( EventM(..)
+  , getVtyContext
  )
 where

@ -23,3 +24,6 @@ newtype EventM n s a =
 instance MonadState s (EventM n s) where
    get = EventM $ lift $ gets applicationState
    put s = EventM $ lift $ modify $ \es -> es { applicationState = s }
+
+getVtyContext :: EventM n s VtyContext
+getVtyContext = EventM $ lift $ gets vtyContext
--- a/src/Brick/Types/Internal.hs
+++ b/src/Brick/Types/Internal.hs
@ -45,6 +45,7 @@ module Brick.Types.Internal
  , Size(..)

  , EventState(..)
+  , VtyContext(..)
  , EventRO(..)
  , NextAction(..)
  , Result(..)
@ -82,6 +83,7 @@ module Brick.Types.Internal
  )
 where

+import Control.Concurrent (ThreadId)
 import Control.Monad.Reader
 import Control.Monad.State.Strict
 import Lens.Micro (_1, _2, Lens')
@ -232,9 +234,17 @@ data EventState n s =
       , cacheInvalidateRequests :: !(S.Set (CacheInvalidateRequest n))
       , requestedVisibleNames :: !(S.Set n)
       , applicationState :: !s
-       , nextAction :: !(NextAction s)
+       , nextAction :: !NextAction
+       , vtyContext :: VtyContext
       }

+data VtyContext =
+    VtyContext { vtyContextBuilder :: IO Vty
+               , vtyContextHandle :: Vty
+               , vtyContextThread :: ThreadId
+               , vtyContextPutEvent :: Event -> IO ()
+               }
+
 -- | An extent of a named area: its size, location, and origin.
 data Extent n = Extent { extentName      :: !n
                       , extentUpperLeft :: !Location
@ -243,12 +253,10 @@ data Extent n = Extent { extentName      :: !n
                       deriving (Show, Read, Generic, NFData)

 -- | The type of actions to take upon completion of an event handler.
-data NextAction s =
+data NextAction =
    Continue
    | ContinueWithoutRedraw
-    | SuspendAndResume (IO s)
    | Halt
-    deriving Functor

 -- | Scrolling direction.
 data Direction = Up
@ -366,7 +374,6 @@ data BrickEvent n e = VtyEvent Event
                    deriving (Show, Eq, Ord)

 data EventRO n = EventRO { eventViewportMap :: M.Map n Viewport
-                         , eventVtyHandle :: Vty
                         , latestExtents :: [Extent n]
                         , oldState :: RenderState n
                         }