diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs index 138199b..162bba6 100644 --- a/programs/EditDemo.hs +++ b/programs/EditDemo.hs @@ -58,8 +58,8 @@ appEvent (T.VtyEvent (V.EvKey V.KBackTab [])) = appEvent ev = do r <- use focusRing case F.focusGetCurrent r of - Just Edit1 -> T.withLens edit1 $ E.handleEditorEvent ev - Just Edit2 -> T.withLens edit2 $ E.handleEditorEvent ev + Just Edit1 -> zoom edit1 $ E.handleEditorEvent ev + Just Edit2 -> zoom edit2 $ E.handleEditorEvent ev Nothing -> return () initialState :: St diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs index 179dcb7..11d585a 100644 --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -88,7 +88,7 @@ infoLayer st = T.Widget T.Fixed T.Fixed $ do appEvent :: T.BrickEvent Name e -> T.EventM Name St () appEvent ev@(T.MouseDown n _ _ loc) = do lastReportedClick .= Just (n, loc) - T.withLens edit $ E.handleEditorEvent ev + zoom edit $ E.handleEditorEvent ev appEvent (T.MouseUp {}) = lastReportedClick .= Nothing appEvent (T.VtyEvent (V.EvMouseUp {})) = @@ -100,7 +100,7 @@ appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt appEvent ev = - T.withLens edit $ E.handleEditorEvent ev + zoom edit $ E.handleEditorEvent ev aMap :: AttrMap aMap = attrMap V.defAttr diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index eccc8d1..23b8a3f 100644 --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -266,14 +266,13 @@ customMainWithVty initialVty buildVty mUserChan app initialAppState = do 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 mempty emptyRS - ((), eState) <- runStateT (runReaderT (runEventM (appStartEvent app)) eventRO) emptyES + (((), appState), eState) <- runStateT (runStateT (runReaderT (runEventM (appStartEvent app)) eventRO) initialAppState) emptyES let initialRS = RS { viewportMap = M.empty , rsScrollRequests = esScrollRequests eState , observedNames = S.empty @@ -283,7 +282,7 @@ customMainWithVty initialVty buildVty mUserChan app initialAppState = do , reportedExtents = mempty } - (s, ctx) <- runWithVty vtyCtx brickChan mUserChan app initialRS (applicationState eState) + (s, ctx) <- runWithVty vtyCtx brickChan mUserChan app initialRS appState `E.catch` (\(e::E.SomeException) -> shutdownVtyContext vtyCtx >> E.throw e) -- Shut down the context's event thread but do NOT shut down Vty @@ -395,12 +394,12 @@ runVty vtyCtx readEvent app appState rs prevExtents draw = do _ -> return (e, firstRS, exts) _ -> return (e, firstRS, exts) - let emptyES = ES [] mempty mempty appState Continue vtyCtx + let emptyES = ES [] mempty mempty Continue vtyCtx eventRO = EventRO (viewportMap nextRS) nextExts nextRS - ((), eState) <- runStateT (runReaderT (runEventM (appHandleEvent app e')) - eventRO) emptyES - return ( applicationState eState + (((), newAppState), eState) <- runStateT (runStateT (runReaderT (runEventM (appHandleEvent app e')) + eventRO) appState) emptyES + return ( newAppState , nextAction eState , nextRS { rsScrollRequests = esScrollRequests eState , renderCache = applyInvalidations (cacheInvalidateRequests eState) $ @@ -467,18 +466,18 @@ getVtyHandle = vtyContextHandle <$> getVtyContext setVtyContext :: VtyContext -> EventM n s () setVtyContext ctx = - EventM $ lift $ modify $ \s -> s { vtyContext = ctx } + EventM $ lift $ lift $ modify $ \s -> s { vtyContext = ctx } -- | Invalidate the rendering cache entry with the specified resource -- name. invalidateCacheEntry :: (Ord n) => n -> EventM n s () invalidateCacheEntry n = EventM $ do - lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s }) + lift $ lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s }) -- | Invalidate the entire rendering cache. invalidateCache :: (Ord n) => EventM n s () invalidateCache = EventM $ do - lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s }) + lift $ lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s }) getRenderState :: EventM n s (RenderState n) getRenderState = EventM $ asks oldState @@ -567,7 +566,7 @@ data ViewportScroll n = addScrollRequest :: (n, ScrollRequest) -> EventM n s () addScrollRequest req = EventM $ do - lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s }) + lift $ lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s }) -- | Build a viewport scroller for the viewport with the specified name. viewportScroll :: n -> ViewportScroll n @@ -595,13 +594,13 @@ viewportScroll n = -- to save on redraw cost. continueWithoutRedraw :: EventM n s () continueWithoutRedraw = - EventM $ lift $ modify $ \es -> es { nextAction = ContinueWithoutRedraw } + EventM $ lift $ lift $ modify $ \es -> es { nextAction = ContinueWithoutRedraw } -- | Halt the event loop and return the specified application state as -- the final state value. halt :: EventM n s () halt = - EventM $ lift $ modify $ \es -> es { nextAction = Halt } + EventM $ lift $ lift $ modify $ \es -> es { nextAction = Halt } -- | Suspend the event loop, save the terminal state, and run the -- specified action. When it returns an application state value, restore @@ -640,4 +639,4 @@ suspendAndResume' act = do -- at rendering time. makeVisible :: (Ord n) => n -> EventM n s () makeVisible n = EventM $ do - lift $ modify (\s -> s { requestedVisibleNames = S.insert n $ requestedVisibleNames s }) + lift $ lift $ modify (\s -> s { requestedVisibleNames = S.insert n $ requestedVisibleNames s }) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index 69bdefc..c4070d2 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -29,8 +29,6 @@ module Brick.Types -- * Event-handling types and functions , EventM , BrickEvent(..) - , withLens - , withFirst , nestEventM , nestEventM' @@ -96,12 +94,13 @@ module Brick.Types , gets , put , modify + , zoom ) where -import Lens.Micro (_1, _2, to, (^.), Lens', Traversal') +import Lens.Micro (_1, _2, to, (^.)) import Lens.Micro.Type (Getting) -import Lens.Micro.Mtl ((.=), (<~), preuse, use) +import Lens.Micro.Mtl (zoom) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif @@ -133,53 +132,24 @@ nestEventM :: a -> EventM n s (a, b) nestEventM s' act = do ro <- EventM ask - s <- EventM $ lift get + es <- EventM $ lift $ lift get vtyCtx <- getVtyContext - let stInner = ES { applicationState = s' - , nextAction = Continue - , esScrollRequests = esScrollRequests s - , cacheInvalidateRequests = cacheInvalidateRequests s - , requestedVisibleNames = requestedVisibleNames s + let stInner = ES { nextAction = Continue + , esScrollRequests = esScrollRequests es + , cacheInvalidateRequests = cacheInvalidateRequests es + , requestedVisibleNames = requestedVisibleNames es , vtyContext = vtyCtx } - (actResult, stInnerFinal) <- liftIO $ runStateT (runReaderT (runEventM act) ro) stInner + ((actResult, newSt), stInnerFinal) <- liftIO $ runStateT (runStateT (runReaderT (runEventM act) ro) s') stInner - EventM $ lift $ modify $ \st -> st { nextAction = nextAction stInnerFinal - , esScrollRequests = esScrollRequests stInnerFinal - , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal - , requestedVisibleNames = requestedVisibleNames stInnerFinal - , vtyContext = vtyContext stInnerFinal - } - return (applicationState stInnerFinal, actResult) - --- | Given a lens into a field of the current state, focus mutations on --- the state field itself. -withLens :: Lens' s a - -- ^ The lens to use to extract and store the state - -- mutated by the action. - -> EventM n a b - -- ^ The action to run, scoped over some state to manage. - -> EventM n s b -withLens target act = do - val <- use target - (val', result) <- nestEventM val act - target .= val' - return result - --- | Given a traversal into the current state, focus mutations on the --- first target of the traversal. If the traversal has no targets, this --- silently does nothing. -withFirst :: Traversal' s a - -- ^ The traversal to target the state to be modified. - -> EventM n a () - -- ^ The action to run, scoped over the first target of the - -- traversal. - -> EventM n s () -withFirst target act = do - mVal <- preuse target - case mVal of - Nothing -> return () - Just val -> target <~ nestEventM' val act + EventM $ lift $ lift $ modify $ + \st -> st { nextAction = nextAction stInnerFinal + , esScrollRequests = esScrollRequests stInnerFinal + , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal + , requestedVisibleNames = requestedVisibleNames stInnerFinal + , vtyContext = vtyContext stInnerFinal + } + return (newSt, actResult) -- | The rendering context's current drawing attribute. attrL :: forall r n. Getting r (Context n) Attr diff --git a/src/Brick/Types/EventM.hs b/src/Brick/Types/EventM.hs index bc97f03..af74e03 100644 --- a/src/Brick/Types/EventM.hs +++ b/src/Brick/Types/EventM.hs @@ -1,6 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Brick.Types.EventM ( EventM(..) , getVtyContext @@ -10,20 +12,27 @@ where import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) import Control.Monad.Reader import Control.Monad.State.Strict +import Lens.Micro.Mtl +import Lens.Micro.Mtl.Internal import Brick.Types.Internal -- | The monad in which event handlers run. newtype EventM n s a = - EventM { runEventM :: ReaderT (EventRO n) (StateT (EventState n s) IO) a + EventM { runEventM :: ReaderT (EventRO n) (StateT s (StateT (EventState n) IO)) a } deriving ( Functor, Applicative, Monad, MonadIO , MonadThrow, MonadCatch, MonadMask, MonadFail ) instance MonadState s (EventM n s) where - get = EventM $ lift $ gets applicationState - put s = EventM $ lift $ modify $ \es -> es { applicationState = s } + get = EventM $ lift get + put = EventM . lift . put getVtyContext :: EventM n s VtyContext -getVtyContext = EventM $ lift $ gets vtyContext +getVtyContext = EventM $ lift $ lift $ gets vtyContext + +type instance Zoomed (EventM n s) = Zoomed (StateT s (StateT (EventState n) IO)) + +instance Zoom (EventM n s) (EventM n t) s t where + zoom l (EventM m) = EventM (zoom l m) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index d4553e6..a82b177 100644 --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -229,11 +229,10 @@ data CacheInvalidateRequest n = | InvalidateEntire deriving (Ord, Eq) -data EventState n s = +data EventState n = ES { esScrollRequests :: ![(n, ScrollRequest)] , cacheInvalidateRequests :: !(S.Set (CacheInvalidateRequest n)) , requestedVisibleNames :: !(S.Set n) - , applicationState :: !s , nextAction :: !NextAction , vtyContext :: VtyContext } diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs index 45051b0..499444a 100644 --- a/src/Brick/Widgets/FileBrowser.hs +++ b/src/Brick/Widgets/FileBrowser.hs @@ -608,19 +608,19 @@ actionFileBrowserSelectCurrent = actionFileBrowserListPageUp :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListPageUp = - withLens fileBrowserEntriesL listMovePageUp + zoom fileBrowserEntriesL listMovePageUp actionFileBrowserListPageDown :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListPageDown = - withLens fileBrowserEntriesL listMovePageDown + zoom fileBrowserEntriesL listMovePageDown actionFileBrowserListHalfPageUp :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListHalfPageUp = - withLens fileBrowserEntriesL (listMoveByPages (-0.5::Double)) + zoom fileBrowserEntriesL (listMoveByPages (-0.5::Double)) actionFileBrowserListHalfPageDown :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListHalfPageDown = - withLens fileBrowserEntriesL (listMoveByPages (0.5::Double)) + zoom fileBrowserEntriesL (listMoveByPages (0.5::Double)) actionFileBrowserListTop :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListTop = @@ -707,7 +707,7 @@ handleFileBrowserEventCommon e = Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl] -> actionFileBrowserListPrev _ -> - withLens fileBrowserEntriesL $ handleListEvent e + zoom fileBrowserEntriesL $ handleListEvent e -- | If the browser's current entry is selectable according to -- @fileBrowserSelectable@, add it to the selection set and return.