Remove withLens and withFirst in lieu of a Zoom instance for EventM

This change makes it possible to use the "zoom" function from
microlens-mtl to zoom in on a state field in EventM. This change adds a
re-export of "zoom" to Brick.Types for convenience.

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

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

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 })

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

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)

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
        }

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.