Finish most proof of concept internals updates for EventM changes

src/Brick/Forms.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 -- | Note - this API is designed to support a narrow (but common!) set
 -- of use cases. If you find that you need more customization than this
 -- offers, then you will need to consider building your own layout and
@@ -85,6 +86,7 @@ module Brick.Forms
   )
 where
 
+import Control.Monad.State (gets, get, put, modify)
 import Graphics.Vty hiding (showCursor)
 #if !(MIN_VERSION_base(4,11,0))
 import Data.Monoid
@@ -103,6 +105,7 @@ import qualified Data.Text as T
 import Text.Read (readMaybe)
 
 import Lens.Micro
+import Lens.Micro.Mtl
 
 -- | A form field. This represents an interactive input field in the
 -- form. Its user input is validated and thus converted into a type of
@@ -138,7 +141,7 @@ data FormField a b e n =
               -- ^ A function to render this form field. Parameters are
               -- whether the field is currently focused, followed by the
               -- field state.
-              , formFieldHandleEvent :: BrickEvent n e -> b -> EventM n b
+              , formFieldHandleEvent :: BrickEvent n e -> EventM n b ()
               -- ^ An event handler for this field. This receives the
               -- event and the field state and returns a new field
               -- state.
@@ -216,6 +219,8 @@ data Form s e n =
          -- ^ Concatenation function for this form's field renderings.
          }
 
+suffixLenses ''Form
+
 -- | Compose a new rendering augmentation function with the one in the
 -- form field collection. For example, we might put a label on the left
 -- side of a form field:
@@ -328,9 +333,9 @@ checkboxCustomField :: (Ord n, Show n)
 checkboxCustomField lb check rb stLens name label initialState =
     let initVal = initialState ^. stLens
 
-        handleEvent (MouseDown n _ _ _) s | n == name = return $ not s
-        handleEvent (VtyEvent (EvKey (KChar ' ') [])) s = return $ not s
-        handleEvent _ s = return s
+        handleEvent (MouseDown n _ _ _) | n == name = modify not
+        handleEvent (VtyEvent (EvKey (KChar ' ') [])) = modify not
+        handleEvent _ = return ()
 
     in FormFieldState { formFieldState = initVal
                       , formFields = [ FormField name Just True
@@ -385,8 +390,8 @@ listField options stLens renderItem itemHeight name initialState =
                                Just e -> listMoveToElement e l
                setList s l = s & stLens .~ (snd <$> listSelectedElement l)
 
-        handleEvent (VtyEvent e) s = handleListEvent e s
-        handleEvent _ s = return s
+        handleEvent (VtyEvent e) = handleListEvent e
+        handleEvent _ = return ()
 
     in FormFieldState { formFieldState = initVal
                       , formFields = [ FormField name Just True
@@ -447,12 +452,12 @@ radioCustomField lb check rb stLens options initialState =
                 [(val, _, _)] -> Just val
                 _ -> Nothing
 
-        handleEvent _ (MouseDown n _ _ _) s =
+        handleEvent _ (MouseDown n _ _ _) =
             case lookupOptionValue n of
-                Nothing -> return s
-                Just v -> return v
-        handleEvent new (VtyEvent (EvKey (KChar ' ') [])) _ = return new
-        handleEvent _ _ s = return s
+                Nothing -> return ()
+                Just v -> put v
+        handleEvent new (VtyEvent (EvKey (KChar ' ') [])) = put new
+        handleEvent _ _ = return ()
 
         optionFields = mkOptionField <$> options
         mkOptionField (val, name, label) =
@@ -755,44 +760,30 @@ renderFormFieldState fr (FormFieldState st _ _ fields helper concatFields) =
 -- lens. The external validation flag is ignored during this step to
 -- ensure that external validators have a chance to get the intermediate
 -- validated value.
-handleFormEvent :: (Eq n) => BrickEvent n e -> Form s e n -> EventM n (Form s e n)
-handleFormEvent (VtyEvent (EvKey (KChar '\t') [])) f =
-    return $ f { formFocus = focusNext $ formFocus f }
-handleFormEvent (VtyEvent (EvKey KBackTab [])) f =
-    return $ f { formFocus = focusPrev $ formFocus f }
-handleFormEvent e@(MouseDown n _ _ _) f =
-    handleFormFieldEvent n e $ f { formFocus = focusSetCurrent n (formFocus f) }
-handleFormEvent e@(MouseUp n _ _) f =
-    handleFormFieldEvent n e $ f { formFocus = focusSetCurrent n (formFocus f) }
-handleFormEvent e@(VtyEvent (EvKey KUp [])) f =
-    case focusGetCurrent (formFocus f) of
-        Nothing -> return f
-        Just n  ->
-            case getFocusGrouping f n of
-                Nothing -> forwardToCurrent e f
-                Just grp -> return $ f { formFocus = focusSetCurrent (entryBefore grp n) (formFocus f) }
-handleFormEvent e@(VtyEvent (EvKey KDown [])) f =
-    case focusGetCurrent (formFocus f) of
-        Nothing -> return f
-        Just n  ->
-            case getFocusGrouping f n of
-                Nothing -> forwardToCurrent e f
-                Just grp -> return $ f { formFocus = focusSetCurrent (entryAfter grp n) (formFocus f) }
-handleFormEvent e@(VtyEvent (EvKey KLeft [])) f =
-    case focusGetCurrent (formFocus f) of
-        Nothing -> return f
-        Just n  ->
-            case getFocusGrouping f n of
-                Nothing -> forwardToCurrent e f
-                Just grp -> return $ f { formFocus = focusSetCurrent (entryBefore grp n) (formFocus f) }
-handleFormEvent e@(VtyEvent (EvKey KRight [])) f =
-    case focusGetCurrent (formFocus f) of
-        Nothing -> return f
-        Just n  ->
-            case getFocusGrouping f n of
-                Nothing -> forwardToCurrent e f
-                Just grp -> return $ f { formFocus = focusSetCurrent (entryAfter grp n) (formFocus f) }
-handleFormEvent e f = forwardToCurrent e f
+handleFormEvent :: (Eq n) => BrickEvent n e -> EventM n (Form s e n) ()
+handleFormEvent (VtyEvent (EvKey (KChar '\t') [])) =
+    formFocusL %= focusNext
+handleFormEvent (VtyEvent (EvKey KBackTab [])) =
+    formFocusL %= focusPrev
+handleFormEvent e@(MouseDown n _ _ _) = do
+    formFocusL %= focusSetCurrent n
+    handleFormFieldEvent n e
+handleFormEvent e@(MouseUp n _ _) = do
+    formFocusL %= focusSetCurrent n
+    handleFormFieldEvent n e
+handleFormEvent e@(VtyEvent (EvKey KUp [])) =
+    withFocusAndGrouping e $ \n grp ->
+        formFocusL %= focusSetCurrent (entryBefore grp n)
+handleFormEvent e@(VtyEvent (EvKey KDown [])) =
+    withFocusAndGrouping e $ \n grp ->
+        formFocusL %= focusSetCurrent (entryAfter grp n)
+handleFormEvent e@(VtyEvent (EvKey KLeft [])) =
+    withFocusAndGrouping e $ \n grp ->
+        formFocusL %= focusSetCurrent (entryBefore grp n)
+handleFormEvent e@(VtyEvent (EvKey KRight [])) =
+    withFocusAndGrouping e $ \n grp ->
+        formFocusL %= focusSetCurrent (entryAfter grp n)
+handleFormEvent e = forwardToCurrent e
 
 getFocusGrouping :: (Eq n) => Form s e n -> n -> Maybe [n]
 getFocusGrouping f n = findGroup (formFieldStates f)
@@ -816,16 +807,32 @@ entryBefore as a =
         i' = if i == 0 then length as - 1 else i - 1
     in as !! i'
 
-forwardToCurrent :: (Eq n) => BrickEvent n e -> Form s e n -> EventM n (Form s e n)
-forwardToCurrent e f =
-    case focusGetCurrent (formFocus f) of
-        Nothing -> return f
-        Just n  -> handleFormFieldEvent n e f
+withFocusAndGrouping :: (Eq n) => BrickEvent n e -> (n -> [n] -> EventM n (Form s e n) ()) -> EventM n (Form s e n) ()
+withFocusAndGrouping e act = do
+    foc <- gets formFocus
+    case focusGetCurrent foc of
+        Nothing -> return ()
+        Just n -> do
+            f <- get
+            case getFocusGrouping f n of
+                Nothing -> forwardToCurrent e
+                Just grp -> act n grp
 
-handleFormFieldEvent :: (Eq n) => n -> BrickEvent n e -> Form s e n -> EventM n (Form s e n)
-handleFormFieldEvent n ev f = findFieldState [] (formFieldStates f)
-    where
-        findFieldState _ [] = return f
+withFocus :: (n -> EventM n (Form s e n) ()) -> EventM n (Form s e n) ()
+withFocus act = do
+    foc <- gets formFocus
+    case focusGetCurrent foc of
+        Nothing -> return ()
+        Just n -> act n
+
+forwardToCurrent :: (Eq n) => BrickEvent n e -> EventM n (Form s e n) ()
+forwardToCurrent e =
+    withFocus $ \n -> do
+        handleFormFieldEvent n e
+
+handleFormFieldEvent :: (Eq n) => n -> BrickEvent n e -> EventM n (Form s e n) ()
+handleFormFieldEvent n ev = do
+    let findFieldState _ [] = return ()
         findFieldState prev (e:es) =
             case e of
                 FormFieldState st stLens upd fields helper concatAll -> do
@@ -833,7 +840,7 @@ handleFormFieldEvent n ev f = findFieldState [] (formFieldStates f)
                         findField (field:rest) =
                             case field of
                                 FormField n' validate _ _ handleFunc | n == n' -> do
-                                    nextSt <- handleFunc ev st
+                                    nextSt <- runEventMWithState st (handleFunc ev)
                                     -- If the new state validates, go ahead and update
                                     -- the form state with it.
                                     case validate nextSt of
@@ -844,10 +851,12 @@ handleFormFieldEvent n ev f = findFieldState [] (formFieldStates f)
                     result <- findField fields
                     case result of
                         Nothing -> findFieldState (prev <> [e]) es
-                        Just (newSt, maybeSt) ->
+                        Just (newSt, maybeSt) -> do
                             let newFieldState = FormFieldState newSt stLens upd fields helper concatAll
-                            in return $ f { formFieldStates = prev <> [newFieldState] <> es
-                                          , formState = case maybeSt of
-                                              Nothing -> formState f
-                                              Just s  -> formState f & stLens .~ s
-                                          }
+                            formFieldStatesL .= prev <> [newFieldState] <> es
+                            case maybeSt of
+                              Nothing -> return ()
+                              Just s  -> formStateL.stLens .= s
+
+    states <- gets formFieldStates
+    findFieldState [] states

src/Brick/Main.hs

@@ -9,7 +9,6 @@ module Brick.Main
   , simpleApp
 
   -- * Event handler functions
-  , continue
   , continueWithoutRedraw
   , halt
   , suspendAndResume
@@ -168,7 +167,7 @@ simpleApp w =
 -- value for simple applications using the 'Event' type that do not need
 -- to get more sophisticated user input.
 resizeOrQuit :: BrickEvent n e -> EventM n s ()
-resizeOrQuit (VtyEvent (EvResize _ _)) = continue
+resizeOrQuit (VtyEvent (EvResize _ _)) = return ()
 resizeOrQuit _ = halt
 
 data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a)
@@ -557,12 +556,6 @@ viewportScroll n =
                    , setLeft            = \i ->   addScrollRequest (n, SetLeft i)
                    }
 
--- | Continue running the event loop with the specified application
--- state.
-continue :: EventM n s ()
-continue =
-    EventM $ lift $ modify $ \es -> es { nextAction = Continue }
-
 -- | Continue running the event loop with the specified application
 -- state without redrawing the screen. This is faster than 'continue'
 -- because it skips the redraw, but the drawback is that you need to

src/Brick/Types.hs

@@ -34,6 +34,7 @@ module Brick.Types
   , BrickEvent(..)
   , handleEventLensed
   , updateWithLens
+  , runEventMWithState
 
   -- * Rendering infrastructure
   , RenderM
@@ -97,6 +98,7 @@ where
 
 import Lens.Micro (_1, _2, to, (^.), (&), (.~), Lens')
 import Lens.Micro.Type (Getting)
+import Lens.Micro.Mtl ((.=), use)
 import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
 #if !MIN_VERSION_base(4,13,0)
 import Control.Monad.Fail (MonadFail)
@@ -131,6 +133,41 @@ handleEventLensed :: Lens' s a
 handleEventLensed target handleEvent ev =
     updateWithLens target (handleEvent ev)
 
+runEventMWithState :: a
+                   -- ^ The lens to use to extract and store the state
+                   -- mutated by the action.
+                   -> EventM n a ()
+                   -- ^ The action to run.
+                   -> EventM n s a
+runEventMWithState s' act = do
+    ro <- EventM ask
+    s <- EventM $ lift get
+    let stInner = ES { applicationState = s'
+                     , nextAction = Continue
+                     , esScrollRequests = esScrollRequests s
+                     , cacheInvalidateRequests = cacheInvalidateRequests s
+                     , requestedVisibleNames = requestedVisibleNames s
+                     }
+    ((), 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
+                                       , esScrollRequests = esScrollRequests stInnerFinal
+                                       , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal
+                                       , requestedVisibleNames = requestedVisibleNames stInnerFinal
+                                       }
+    return finalSt
+
 updateWithLens :: Lens' s a
                -- ^ The lens to use to extract and store the state
                -- mutated by the action.
@@ -138,16 +175,9 @@ updateWithLens :: Lens' s a
                -- ^ The action to run.
                -> EventM n s ()
 updateWithLens target act = do
-    ro <- EventM ask
-    s <- EventM $ lift get
-    let stInner = ES { applicationState = (applicationState s)^.target
-                     , nextAction = Continue
-                     , esScrollRequests = esScrollRequests s
-                     , cacheInvalidateRequests = cacheInvalidateRequests s
-                     , requestedVisibleNames = requestedVisibleNames s
-                     }
-    ((), stInnerFinal) <- liftIO $ runStateT (runReaderT (runEventM act) ro) stInner
-    EventM $ lift $ put $ s { applicationState = applicationState s & target .~ applicationState stInnerFinal }
+    val <- use target
+    val' <- runEventMWithState val act
+    target .= val'
 
 -- | The monad in which event handlers run. Although it may be tempting
 -- to dig into the reader value yourself, just use