From 5db48f2820a0710f5a1a016e71fc63a39a0f7b12 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Fri, 15 Jul 2022 17:04:18 -0700 Subject: [PATCH 01/37] Initial refactor of EventM to be a state monad (also migrates to mtl) --- brick.cabal | 2 +- src/Brick/Main.hs | 107 ++++++++++---------- src/Brick/Types.hs | 38 +++++--- src/Brick/Types/Internal.hs | 29 +++--- src/Brick/Widgets/Core.hs | 6 +- src/Brick/Widgets/Dialog.hs | 7 +- src/Brick/Widgets/Edit.hs | 12 ++- src/Brick/Widgets/FileBrowser.hs | 162 +++++++++++++++---------------- src/Brick/Widgets/Internal.hs | 5 +- src/Brick/Widgets/List.hs | 62 ++++++------ 10 files changed, 220 insertions(+), 210 deletions(-) diff --git a/brick.cabal b/brick.cabal index c191e7d..c195ed3 100644 --- a/brick.cabal +++ b/brick.cabal @@ -113,7 +113,6 @@ library build-depends: base >= 4.9.0.0 && < 4.17.0.0, vty >= 5.36, - transformers, data-clist >= 0.1, directory >= 1.2.5.0, dlist, @@ -123,6 +122,7 @@ library microlens >= 0.3.0.0, microlens-th, microlens-mtl, + mtl, config-ini, vector, contravariant, diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index 41e7d5a..a3cd947 100644 --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -53,10 +53,8 @@ where import qualified Control.Exception as E import Lens.Micro ((^.), (&), (.~), (%~), _1, _2) -import Control.Monad (forever) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader +import Control.Monad.State +import Control.Monad.Reader import Control.Concurrent (forkIO, killThread) import qualified Data.Foldable as F import Data.List (find) @@ -110,13 +108,13 @@ data App s e n = -- is that many widgets may request a cursor placement but your -- application state is what you probably want to use to decide -- which one wins. - , appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) + , appHandleEvent :: BrickEvent n e -> EventM n s () -- ^ This function takes the current application state and an -- event and returns an action to be taken and a corresponding -- transformed application state. Possible options are -- 'continue', 'continueWithoutRedraw', 'suspendAndResume', and -- 'halt'. - , appStartEvent :: s -> EventM n s + , appStartEvent :: EventM n s () -- ^ This function gets called once just prior to the first -- drawing of your application. Here is where you can make -- initial scrolling requests, for example. @@ -159,7 +157,7 @@ simpleApp :: Widget n -> App s e n simpleApp w = App { appDraw = const [w] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap defAttr [] , appChooseCursor = neverShowCursor } @@ -169,9 +167,9 @@ simpleApp w = -- a halt. This is a convenience function useful as an 'appHandleEvent' -- value for simple applications using the 'Event' type that do not need -- to get more sophisticated user input. -resizeOrQuit :: s -> BrickEvent n e -> EventM n (Next s) -resizeOrQuit s (VtyEvent (EvResize _ _)) = continue s -resizeOrQuit s _ = halt s +resizeOrQuit :: BrickEvent n e -> EventM n s () +resizeOrQuit (VtyEvent (EvResize _ _)) = continue +resizeOrQuit _ = halt data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a) | InternalHalt a @@ -196,17 +194,17 @@ runWithVty vty brickChan mUserChan app initialRS initialSt = do let nextRS = if draw then resetRenderState rs else rs - (result, newRS, newExtents) <- runVty vty readEvent app st nextRS es draw + (nextSt, result, newRS, newExtents) <- runVty vty readEvent app st nextRS es draw case result of SuspendAndResume act -> do killThread pid return $ InternalSuspendAndResume newRS act - Halt s -> do + Halt -> do killThread pid - return $ InternalHalt s - Continue s -> runInner newRS newExtents True s - ContinueWithoutRedraw s -> - runInner newRS newExtents False s + return $ InternalHalt nextSt + Continue -> runInner newRS newExtents True nextSt + ContinueWithoutRedraw -> + runInner newRS newExtents False nextSt runInner initialRS mempty True initialSt -- | The custom event loop entry point to use when the simpler ones @@ -278,11 +276,11 @@ customMainWithVty initialVty buildVty mUserChan app initialAppState = do newVty <- buildVty run newVty (newRS { renderCache = mempty }) newAppState brickChan - let emptyES = ES [] mempty mempty + let emptyES = ES [] mempty mempty initialAppState Continue emptyRS = RS M.empty mempty S.empty mempty mempty mempty mempty eventRO = EventRO M.empty initialVty mempty emptyRS - (st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) eventRO) emptyES + ((), eState) <- runStateT (runReaderT (runEventM (appStartEvent app)) eventRO) emptyES let initialRS = RS { viewportMap = M.empty , rsScrollRequests = esScrollRequests eState , observedNames = S.empty @@ -292,7 +290,7 @@ customMainWithVty initialVty buildVty mUserChan app initialAppState = do , reportedExtents = mempty } brickChan <- newBChan 20 - run initialVty initialRS st brickChan + run initialVty initialRS (applicationState eState) brickChan supplyVtyEvents :: Vty -> BChan (BrickEvent n e) -> IO () supplyVtyEvents vty chan = @@ -308,7 +306,7 @@ runVty :: (Ord n) -> RenderState n -> [Extent n] -> Bool - -> IO (Next s, RenderState n, [Extent n]) + -> IO (s, NextAction s, RenderState n, [Extent n]) runVty vty readEvent app appState rs prevExtents draw = do (firstRS, exts) <- if draw then renderApp vty app appState rs @@ -374,12 +372,13 @@ runVty vty readEvent app appState rs prevExtents draw = do _ -> return (e, firstRS, exts) _ -> return (e, firstRS, exts) - let emptyES = ES [] mempty mempty + let emptyES = ES [] mempty mempty appState Continue eventRO = EventRO (viewportMap nextRS) vty nextExts nextRS - (next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e')) + ((), eState) <- runStateT (runReaderT (runEventM (appHandleEvent app e')) eventRO) emptyES - return ( next + return ( applicationState eState + , nextAction eState , nextRS { rsScrollRequests = esScrollRequests eState , renderCache = applyInvalidations (cacheInvalidateRequests eState) $ renderCache nextRS @@ -410,7 +409,7 @@ applyInvalidations ns cache = -- associated functions without relying on this function. Those -- functions queue up scrolling requests that can be made in advance of -- the next rendering to affect the viewport. -lookupViewport :: (Ord n) => n -> EventM n (Maybe Viewport) +lookupViewport :: (Ord n) => n -> EventM n s (Maybe Viewport) lookupViewport n = EventM $ asks (M.lookup n . eventViewportMap) -- | Did the specified mouse coordinates (column, row) intersect the @@ -422,7 +421,7 @@ clickedExtent (c, r) (Extent _ (Location (lc, lr)) (w, h)) = -- | Given a resource name, get the most recent rendering extent for the -- name (if any). -lookupExtent :: (Eq n) => n -> EventM n (Maybe (Extent n)) +lookupExtent :: (Eq n) => n -> EventM n s (Maybe (Extent n)) lookupExtent n = EventM $ asks (find f . latestExtents) where f (Extent n' _ _) = n == n' @@ -432,28 +431,28 @@ lookupExtent n = EventM $ asks (find f . latestExtents) -- the list is the most specific extent and the last extent is the most -- generic (top-level). So if two extents A and B both intersected the -- mouse click but A contains B, then they would be returned [B, A]. -findClickedExtents :: (Int, Int) -> EventM n [Extent n] +findClickedExtents :: (Int, Int) -> EventM n s [Extent n] findClickedExtents pos = EventM $ asks (findClickedExtents_ pos . latestExtents) findClickedExtents_ :: (Int, Int) -> [Extent n] -> [Extent n] findClickedExtents_ pos = reverse . filter (clickedExtent pos) -- | Get the Vty handle currently in use. -getVtyHandle :: EventM n Vty +getVtyHandle :: EventM n s Vty getVtyHandle = EventM $ asks eventVtyHandle -- | Invalidate the rendering cache entry with the specified resource -- name. -invalidateCacheEntry :: (Ord n) => n -> EventM n () +invalidateCacheEntry :: (Ord n) => n -> EventM n s () invalidateCacheEntry n = EventM $ do lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s }) -- | Invalidate the entire rendering cache. -invalidateCache :: (Ord n) => EventM n () +invalidateCache :: (Ord n) => EventM n s () invalidateCache = EventM $ do lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s }) -getRenderState :: EventM n (RenderState n) +getRenderState :: EventM n s (RenderState n) getRenderState = EventM $ asks oldState resetRenderState :: RenderState n -> RenderState n @@ -505,45 +504,45 @@ showCursorNamed name locs = -- | A viewport scrolling handle for managing the scroll state of -- viewports. -data ViewportScroll n = +data ViewportScroll n s = ViewportScroll { viewportName :: n -- ^ The name of the viewport to be controlled by -- this scrolling handle. - , hScrollPage :: Direction -> EventM n () + , hScrollPage :: Direction -> EventM n s () -- ^ Scroll the viewport horizontally by one page in -- the specified direction. - , hScrollBy :: Int -> EventM n () + , hScrollBy :: Int -> EventM n s () -- ^ Scroll the viewport horizontally by the -- specified number of rows or columns depending on -- the orientation of the viewport. - , hScrollToBeginning :: EventM n () + , hScrollToBeginning :: EventM n s () -- ^ Scroll horizontally to the beginning of the -- viewport. - , hScrollToEnd :: EventM n () + , hScrollToEnd :: EventM n s () -- ^ Scroll horizontally to the end of the viewport. - , vScrollPage :: Direction -> EventM n () + , vScrollPage :: Direction -> EventM n s () -- ^ Scroll the viewport vertically by one page in -- the specified direction. - , vScrollBy :: Int -> EventM n () + , vScrollBy :: Int -> EventM n s () -- ^ Scroll the viewport vertically by the specified -- number of rows or columns depending on the -- orientation of the viewport. - , vScrollToBeginning :: EventM n () + , vScrollToBeginning :: EventM n s () -- ^ Scroll vertically to the beginning of the viewport. - , vScrollToEnd :: EventM n () + , vScrollToEnd :: EventM n s () -- ^ Scroll vertically to the end of the viewport. - , setTop :: Int -> EventM n () + , setTop :: Int -> EventM n s () -- ^ Set the top row offset of the viewport. - , setLeft :: Int -> EventM n () + , setLeft :: Int -> EventM n s () -- ^ Set the left column offset of the viewport. } -addScrollRequest :: (n, ScrollRequest) -> EventM n () +addScrollRequest :: (n, ScrollRequest) -> EventM n s () addScrollRequest req = EventM $ do lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s }) -- | Build a viewport scroller for the viewport with the specified name. -viewportScroll :: n -> ViewportScroll n +viewportScroll :: n -> ViewportScroll n s viewportScroll n = ViewportScroll { viewportName = n , hScrollPage = \dir -> addScrollRequest (n, HScrollPage dir) @@ -560,8 +559,9 @@ viewportScroll n = -- | Continue running the event loop with the specified application -- state. -continue :: s -> EventM n (Next s) -continue = return . Continue +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' @@ -571,13 +571,15 @@ continue = return . Continue -- 'continue'. This function is for cases where you know that you did -- something that won't have an impact on the screen state and you want -- to save on redraw cost. -continueWithoutRedraw :: s -> EventM n (Next s) -continueWithoutRedraw = return . ContinueWithoutRedraw +continueWithoutRedraw :: EventM n s () +continueWithoutRedraw = + EventM $ lift $ modify $ \es -> es { nextAction = ContinueWithoutRedraw } -- | Halt the event loop and return the specified application state as -- the final state value. -halt :: s -> EventM n (Next s) -halt = return . Halt +halt :: EventM n s () +halt = + EventM $ 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 @@ -588,13 +590,14 @@ halt = return . Halt -- 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 (Next s) -suspendAndResume = return . SuspendAndResume +suspendAndResume :: IO s -> EventM n s () +suspendAndResume act = + EventM $ lift $ modify $ \es -> es { nextAction = SuspendAndResume act } -- | Request that the specified UI element be made visible on the -- next rendering. This is provided to allow event handlers to make -- visibility requests in the same way that the 'visible' function does -- at rendering time. -makeVisible :: (Ord n) => n -> EventM n () +makeVisible :: (Ord n) => n -> EventM n s () makeVisible n = EventM $ do lift $ modify (\s -> s { requestedVisibleNames = S.insert n $ requestedVisibleNames s }) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index 57dfcf7..4b8ddc2 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Brick.Types ( -- * The Widget type @@ -29,7 +31,6 @@ module Brick.Types -- * Event-handling types , EventM(..) - , Next , BrickEvent(..) , handleEventLensed @@ -99,10 +100,9 @@ import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader +import Control.Monad.State.Lazy +import Control.Monad.Reader import Graphics.Vty (Attr) -import Control.Monad.IO.Class import Brick.Types.TH import Brick.Types.Internal @@ -119,30 +119,40 @@ data Padding = Pad Int -- obtains the target value of the specified lens, invokes 'handleEvent' -- on it, and stores the resulting transformed value back in the state -- using the lens. -handleEventLensed :: a - -- ^ The state value. - -> Lens' a b +handleEventLensed :: Lens' s a -- ^ The lens to use to extract and store the target -- of the event. - -> (e -> b -> EventM n b) + -> (e -> EventM n a ()) -- ^ The event handler. -> e -- ^ The event to handle. - -> EventM n a -handleEventLensed v target handleEvent ev = do - newB <- handleEvent ev (v^.target) - return $ v & target .~ newB + -> EventM n s () +handleEventLensed target handleEvent ev = 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 (handleEvent ev)) ro) stInner + EventM $ lift $ put $ s { applicationState = applicationState s & target .~ applicationState stInnerFinal } -- | The monad in which event handlers run. Although it may be tempting -- to dig into the reader value yourself, just use -- 'Brick.Main.lookupViewport'. -newtype EventM n a = - EventM { runEventM :: ReaderT (EventRO n) (StateT (EventState n) IO) a +newtype EventM n s a = + EventM { runEventM :: ReaderT (EventRO n) (StateT (EventState n s) 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 } + -- | The rendering context's current drawing attribute. attrL :: forall r n. Getting r (Context n) Attr attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index 5c186a0..470f72b 100644 --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -46,7 +46,7 @@ module Brick.Types.Internal , EventState(..) , EventRO(..) - , Next(..) + , NextAction(..) , Result(..) , Extent(..) , Edges(..) @@ -82,9 +82,8 @@ module Brick.Types.Internal ) where -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State.Lazy +import Control.Monad.Reader +import Control.Monad.State.Lazy import Lens.Micro (_1, _2, Lens') import Lens.Micro.Mtl (use) import Lens.Micro.TH (makeLenses) @@ -227,10 +226,13 @@ data CacheInvalidateRequest n = | InvalidateEntire deriving (Ord, Eq) -data EventState n = ES { esScrollRequests :: [(n, ScrollRequest)] - , cacheInvalidateRequests :: S.Set (CacheInvalidateRequest n) - , requestedVisibleNames :: S.Set n - } +data EventState n s = + ES { esScrollRequests :: [(n, ScrollRequest)] + , cacheInvalidateRequests :: S.Set (CacheInvalidateRequest n) + , requestedVisibleNames :: S.Set n + , applicationState :: s + , nextAction :: NextAction s + } -- | An extent of a named area: its size, location, and origin. data Extent n = Extent { extentName :: n @@ -240,11 +242,12 @@ data Extent n = Extent { extentName :: n deriving (Show, Read, Generic, NFData) -- | The type of actions to take upon completion of an event handler. -data Next a = Continue a - | ContinueWithoutRedraw a - | SuspendAndResume (IO a) - | Halt a - deriving Functor +data NextAction s = + Continue + | ContinueWithoutRedraw + | SuspendAndResume (IO s) + | Halt + deriving Functor -- | Scrolling direction. data Direction = Up diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs index 3321f87..ee064ed 100644 --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -121,10 +121,8 @@ import Data.Monoid ((<>)) import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, each, to, Lens') import Lens.Micro.Mtl (use, (%=)) -import Control.Monad ((>=>),when) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class (lift) +import Control.Monad.State.Lazy +import Control.Monad.Reader import qualified Data.Foldable as F import qualified Data.Text as T import qualified Data.DList as DL diff --git a/src/Brick/Widgets/Dialog.hs b/src/Brick/Widgets/Dialog.hs index a3a6d5f..a12f9d0 100644 --- a/src/Brick/Widgets/Dialog.hs +++ b/src/Brick/Widgets/Dialog.hs @@ -37,6 +37,7 @@ module Brick.Widgets.Dialog where import Lens.Micro +import Control.Monad.State (modify) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif @@ -72,9 +73,9 @@ data Dialog a = suffixLenses ''Dialog -handleDialogEvent :: Event -> Dialog a -> EventM n (Dialog a) -handleDialogEvent ev d = - return $ case ev of +handleDialogEvent :: Event -> EventM n (Dialog a) () +handleDialogEvent ev = do + modify $ \d -> case ev of EvKey (KChar '\t') [] -> nextButtonBy 1 True d EvKey KBackTab [] -> nextButtonBy (-1) True d EvKey KRight [] -> nextButtonBy 1 False d diff --git a/src/Brick/Widgets/Edit.hs b/src/Brick/Widgets/Edit.hs index c4ddbeb..949591d 100644 --- a/src/Brick/Widgets/Edit.hs +++ b/src/Brick/Widgets/Edit.hs @@ -48,6 +48,8 @@ import Data.Monoid import Lens.Micro import Graphics.Vty (Event(..), Key(..), Modifier(..)) +import Control.Monad.State (get, put) + import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -119,11 +121,10 @@ instance DecodeUtf8 String where handleEditorEvent :: (Eq n, DecodeUtf8 t, Eq t, Z.GenericTextZipper t) => BrickEvent n e - -> Editor t n - -> EventM n (Editor t n) -handleEditorEvent e ed = return $ applyEdit f ed - where - f = case e of + -> EventM n (Editor t n) () +handleEditorEvent e = do + ed <- get + let f = case e of VtyEvent ev -> handleVtyEvent ev MouseDown n _ _ (Location pos) | n == getName ed -> @@ -157,6 +158,7 @@ handleEditorEvent e ed = return $ applyEdit f ed EvKey (KChar '<') [MMeta] -> Z.gotoBOF EvKey (KChar '>') [MMeta] -> Z.gotoEOF _ -> id + put $ applyEdit f ed -- | Construct an editor over 'Text' values editorText :: n diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs index 32ade84..b46eb62 100644 --- a/src/Brick/Widgets/FileBrowser.hs +++ b/src/Brick/Widgets/FileBrowser.hs @@ -143,6 +143,7 @@ where import qualified Control.Exception as E import Control.Monad (forM) import Control.Monad.IO.Class (liftIO) +import Control.Monad.State (get, modify) import Data.Char (toLower, isPrint) import Data.Maybe (fromMaybe, isJust, fromJust) import qualified Data.Foldable as F @@ -155,6 +156,7 @@ import Data.List (sortBy, isSuffixOf) import qualified Data.Set as Set import qualified Data.Vector as V import Lens.Micro +import Lens.Micro.Mtl ((%=)) import Lens.Micro.TH (lensRules, generateUpdateableOptics) import qualified Graphics.Vty as Vty import qualified System.Directory as D @@ -593,126 +595,120 @@ fileBrowserCursor b = snd <$> listSelectedElement (b^.fileBrowserEntriesL) -- * @Esc@, @Ctrl-C@: cancel search mode -- * Text input: update search string -actionFileBrowserBeginSearch :: FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserBeginSearch b = - return $ updateFileBrowserSearch (const $ Just "") b +actionFileBrowserBeginSearch :: EventM n (FileBrowser n) () +actionFileBrowserBeginSearch = + modify $ updateFileBrowserSearch (const $ Just "") -actionFileBrowserSelectEnter :: FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserSelectEnter b = - maybeSelectCurrentEntry b +actionFileBrowserSelectEnter :: EventM n (FileBrowser n) () +actionFileBrowserSelectEnter = + maybeSelectCurrentEntry -actionFileBrowserSelectCurrent :: FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserSelectCurrent b = - selectCurrentEntry b +actionFileBrowserSelectCurrent :: EventM n (FileBrowser n) () +actionFileBrowserSelectCurrent = + selectCurrentEntry -actionFileBrowserListPageUp :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListPageUp b = do - let old = b ^. fileBrowserEntriesL - new <- listMovePageUp old - return $ b & fileBrowserEntriesL .~ new +actionFileBrowserListPageUp :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListPageUp = + handleEventLensed fileBrowserEntriesL listMovePageUp -actionFileBrowserListPageDown :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListPageDown b = do - let old = b ^. fileBrowserEntriesL - new <- listMovePageDown old - return $ b & fileBrowserEntriesL .~ new +actionFileBrowserListPageDown :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListPageDown = + handleEventLensed fileBrowserEntriesL listMovePageDown -actionFileBrowserListHalfPageUp :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListHalfPageUp b = do - let old = b ^. fileBrowserEntriesL - new <- listMoveByPages (-0.5::Double) old - return $ b & fileBrowserEntriesL .~ new +actionFileBrowserListHalfPageUp :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListHalfPageUp b = + handleEventLensed fileBrowserEntriesL (listMoveByPages (-0.5::Double)) -actionFileBrowserListHalfPageDown :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListHalfPageDown b = do - let old = b ^. fileBrowserEntriesL - new <- listMoveByPages (0.5::Double) old - return $ b & fileBrowserEntriesL .~ new +actionFileBrowserListHalfPageDown :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListHalfPageDown = + handleEventLensed fileBrowserEntriesL (listMoveByPages (0.5::Double)) -actionFileBrowserListTop :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListTop b = - return $ b & fileBrowserEntriesL %~ listMoveTo 0 +actionFileBrowserListTop :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListTop = + fileBrowserEntriesL %= listMoveTo 0 -actionFileBrowserListBottom :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListBottom b = do +actionFileBrowserListBottom :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListBottom = do + b <- get let sz = length (listElements $ b^.fileBrowserEntriesL) - return $ b & fileBrowserEntriesL %~ listMoveTo (sz - 1) + fileBrowserEntriesL %= listMoveTo (sz - 1) -actionFileBrowserListNext :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListNext b = - return $ b & fileBrowserEntriesL %~ listMoveBy 1 +actionFileBrowserListNext :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListNext = + fileBrowserEntriesL %= listMoveBy 1 -actionFileBrowserListPrev :: Ord n => FileBrowser n -> EventM n (FileBrowser n) -actionFileBrowserListPrev b = - return $ b & fileBrowserEntriesL %~ listMoveBy (-1) +actionFileBrowserListPrev :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListPrev = + fileBrowserEntriesL %= listMoveBy (-1) -handleFileBrowserEvent :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEvent e b = +handleFileBrowserEvent :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEvent e = do + b <- get if fileBrowserIsSearching b - then handleFileBrowserEventSearching e b - else handleFileBrowserEventNormal e b + then handleFileBrowserEventSearching e + else handleFileBrowserEventNormal e safeInit :: T.Text -> T.Text safeInit t | T.length t == 0 = t | otherwise = T.init t -handleFileBrowserEventSearching :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEventSearching e b = +handleFileBrowserEventSearching :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventSearching e = case e of Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl] -> - return $ updateFileBrowserSearch (const Nothing) b + return $ updateFileBrowserSearch (const Nothing) Vty.EvKey Vty.KEsc [] -> - return $ updateFileBrowserSearch (const Nothing) b + return $ updateFileBrowserSearch (const Nothing) Vty.EvKey Vty.KBS [] -> - return $ updateFileBrowserSearch (fmap safeInit) b + return $ updateFileBrowserSearch (fmap safeInit) Vty.EvKey Vty.KEnter [] -> updateFileBrowserSearch (const Nothing) <$> - maybeSelectCurrentEntry b + maybeSelectCurrentEntry Vty.EvKey (Vty.KChar c) [] -> - return $ updateFileBrowserSearch (fmap (flip T.snoc c)) b + modify $ updateFileBrowserSearch (fmap (flip T.snoc c)) _ -> - handleFileBrowserEventCommon e b + handleFileBrowserEventCommon e -handleFileBrowserEventNormal :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEventNormal e b = +handleFileBrowserEventNormal :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventNormal e = case e of Vty.EvKey (Vty.KChar '/') [] -> -- Begin file search - actionFileBrowserBeginSearch b + actionFileBrowserBeginSearch Vty.EvKey Vty.KEnter [] -> -- Select file or enter directory - actionFileBrowserSelectEnter b + actionFileBrowserSelectEnter Vty.EvKey (Vty.KChar ' ') [] -> -- Select entry - actionFileBrowserSelectCurrent b + actionFileBrowserSelectCurrent _ -> - handleFileBrowserEventCommon e b + handleFileBrowserEventCommon e -handleFileBrowserEventCommon :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEventCommon e b = +handleFileBrowserEventCommon :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventCommon e = case e of Vty.EvKey (Vty.KChar 'b') [Vty.MCtrl] -> - actionFileBrowserListPageUp b + actionFileBrowserListPageUp Vty.EvKey (Vty.KChar 'f') [Vty.MCtrl] -> - actionFileBrowserListPageDown b + actionFileBrowserListPageDown Vty.EvKey (Vty.KChar 'd') [Vty.MCtrl] -> - actionFileBrowserListHalfPageDown b + actionFileBrowserListHalfPageDown Vty.EvKey (Vty.KChar 'u') [Vty.MCtrl] -> - actionFileBrowserListHalfPageUp b + actionFileBrowserListHalfPageUp Vty.EvKey (Vty.KChar 'g') [] -> - actionFileBrowserListTop b + actionFileBrowserListTop Vty.EvKey (Vty.KChar 'G') [] -> - actionFileBrowserListBottom b + actionFileBrowserListBottom Vty.EvKey (Vty.KChar 'j') [] -> - actionFileBrowserListNext b + actionFileBrowserListNext Vty.EvKey (Vty.KChar 'k') [] -> - actionFileBrowserListPrev b + actionFileBrowserListPrev Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl] -> - actionFileBrowserListNext b + actionFileBrowserListNext Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl] -> - actionFileBrowserListPrev b + actionFileBrowserListPrev _ -> - handleEventLensed b fileBrowserEntriesL handleListEvent e + handleEventLensed fileBrowserEntriesL handleListEvent e -- | If the browser's current entry is selectable according to -- @fileBrowserSelectable@, add it to the selection set and return. @@ -720,13 +716,14 @@ handleFileBrowserEventCommon e b = -- directory, set the browser's current path to the selected directory. -- -- Otherwise, return the browser state unchanged. -maybeSelectCurrentEntry :: FileBrowser n -> EventM n (FileBrowser n) -maybeSelectCurrentEntry b = +maybeSelectCurrentEntry :: EventM n (FileBrowser n) () +maybeSelectCurrentEntry = do + b <- get case fileBrowserCursor b of - Nothing -> return b + Nothing -> return () Just entry -> if fileBrowserSelectable b entry - then return $ b & fileBrowserSelectedFilesL %~ Set.insert (fileInfoFilename entry) + then fileBrowserSelectedFilesL %= Set.insert (fileInfoFilename entry) else case fileInfoFileType entry of Just Directory -> liftIO $ setWorkingDirectory (fileInfoFilePath entry) b @@ -735,15 +732,16 @@ maybeSelectCurrentEntry b = Just Directory -> do liftIO $ setWorkingDirectory (fileInfoFilePath entry) b _ -> - return b + return () _ -> - return b + return () -selectCurrentEntry :: FileBrowser n -> EventM n (FileBrowser n) -selectCurrentEntry b = +selectCurrentEntry :: EventM n (FileBrowser n) () +selectCurrentEntry = do + b <- get case fileBrowserCursor b of - Nothing -> return b - Just e -> return $ b & fileBrowserSelectedFilesL %~ Set.insert (fileInfoFilename e) + Nothing -> return () + Just e -> fileBrowserSelectedFilesL %= Set.insert (fileInfoFilename e) -- | Render a file browser. This renders a list of entries in the -- working directory, a cursor to select from among the entries, a diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs index 05ff1d5..5ed651d 100644 --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -10,9 +10,8 @@ where import Lens.Micro ((^.), (&), (%~)) import Lens.Micro.Mtl ((%=)) -import Control.Monad (forM_) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader +import Control.Monad.State.Lazy +import Control.Monad.Reader import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Set as S diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs index f950f49..4b6b874 100644 --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -79,7 +79,7 @@ import Prelude hiding (reverse, splitAt) import Control.Applicative ((<|>)) import Data.Foldable (find, toList) -import Control.Monad.Trans.State (evalState, get, put) +import Control.Monad.State (evalState, modify, get, put) import Lens.Micro ((^.), (^?), (&), (.~), (%~), _2, _head, set) import Data.Functor (($>)) @@ -193,17 +193,16 @@ instance Reversible Seq.Seq where -- * Go to last element (End) handleListEvent :: (Foldable t, Splittable t, Ord n) => Event - -> GenericList n t e - -> EventM n (GenericList n t e) -handleListEvent e theList = + -> EventM n (GenericList n t e) () +handleListEvent e = case e of - EvKey KUp [] -> return $ listMoveUp theList - EvKey KDown [] -> return $ listMoveDown theList - EvKey KHome [] -> return $ listMoveToBeginning theList - EvKey KEnd [] -> return $ listMoveToEnd theList - EvKey KPageDown [] -> listMovePageDown theList - EvKey KPageUp [] -> listMovePageUp theList - _ -> return theList + EvKey KUp [] -> modify listMoveUp + EvKey KDown [] -> modify listMoveDown + EvKey KHome [] -> modify listMoveToBeginning + EvKey KEnd [] -> modify listMoveToEnd + EvKey KPageDown [] -> listMovePageDown + EvKey KPageUp [] -> listMovePageUp + _ -> return () -- | Enable list movement with the vi keys with a fallback handler if -- none match. Use 'handleListEventVi' 'handleListEvent' in place of @@ -219,23 +218,22 @@ handleListEvent e theList = -- * Go to first element (g) -- * Go to last element (G) handleListEventVi :: (Foldable t, Splittable t, Ord n) - => (Event -> GenericList n t e -> EventM n (GenericList n t e)) + => (Event -> EventM n (GenericList n t e) ()) -- ^ Fallback event handler to use if none of the vi keys -- match. -> Event - -> GenericList n t e - -> EventM n (GenericList n t e) -handleListEventVi fallback e theList = + -> EventM n (GenericList n t e) () +handleListEventVi fallback e = case e of - EvKey (KChar 'k') [] -> return $ listMoveUp theList - EvKey (KChar 'j') [] -> return $ listMoveDown theList - EvKey (KChar 'g') [] -> return $ listMoveToBeginning theList - EvKey (KChar 'G') [] -> return $ listMoveToEnd theList - EvKey (KChar 'f') [MCtrl] -> listMovePageDown theList - EvKey (KChar 'b') [MCtrl] -> listMovePageUp theList - EvKey (KChar 'd') [MCtrl] -> listMoveByPages (0.5::Double) theList - EvKey (KChar 'u') [MCtrl] -> listMoveByPages (-0.5::Double) theList - _ -> fallback e theList + EvKey (KChar 'k') [] -> modify listMoveUp + EvKey (KChar 'j') [] -> modify listMoveDown + EvKey (KChar 'g') [] -> modify listMoveToBeginning + EvKey (KChar 'G') [] -> modify listMoveToEnd + EvKey (KChar 'f') [MCtrl] -> listMovePageDown + EvKey (KChar 'b') [MCtrl] -> listMovePageUp + EvKey (KChar 'd') [MCtrl] -> listMoveByPages (0.5::Double) + EvKey (KChar 'u') [MCtrl] -> listMoveByPages (-0.5::Double) + _ -> fallback e -- | Move the list selection to the first element in the list. listMoveToBeginning :: (Foldable t, Splittable t) @@ -474,8 +472,7 @@ listMoveUp = listMoveBy (-1) -- | Move the list selected index up by one page. listMovePageUp :: (Foldable t, Splittable t, Ord n) - => GenericList n t e - -> EventM n (GenericList n t e) + => EventM n (GenericList n t e) () listMovePageUp = listMoveByPages (-1::Double) -- | Move the list selected index down by one. (Moves the cursor down, @@ -487,23 +484,22 @@ listMoveDown = listMoveBy 1 -- | Move the list selected index down by one page. listMovePageDown :: (Foldable t, Splittable t, Ord n) - => GenericList n t e - -> EventM n (GenericList n t e) + => EventM n (GenericList n t e) () listMovePageDown = listMoveByPages (1::Double) -- | Move the list selected index by some (fractional) number of pages. listMoveByPages :: (Foldable t, Splittable t, Ord n, RealFrac m) => m - -> GenericList n t e - -> EventM n (GenericList n t e) -listMoveByPages pages theList = do + -> EventM n (GenericList n t e) () +listMoveByPages pages = do + theList <- get v <- lookupViewport (theList^.listNameL) case v of - Nothing -> return theList + Nothing -> return () Just vp -> do let nElems = round $ pages * fromIntegral (vp^.vpSize._2) / fromIntegral (theList^.listItemHeightL) - return $ listMoveBy nElems theList + modify $ listMoveBy nElems -- | Move the list selected index. -- From 74ba7b6c5621383d8ce6b53c550c613e2017e8bd Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sat, 16 Jul 2022 13:28:47 -0700 Subject: [PATCH 02/37] Add updateWithLens, finish FileBrowser updates --- src/Brick/Types.hs | 14 ++++++++++-- src/Brick/Widgets/FileBrowser.hs | 38 ++++++++++++++++---------------- 2 files changed, 31 insertions(+), 21 deletions(-) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index 4b8ddc2..e5910e2 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -33,6 +33,7 @@ module Brick.Types , EventM(..) , BrickEvent(..) , handleEventLensed + , updateWithLens -- * Rendering infrastructure , RenderM @@ -127,7 +128,16 @@ handleEventLensed :: Lens' s a -> e -- ^ The event to handle. -> EventM n s () -handleEventLensed target handleEvent ev = do +handleEventLensed target handleEvent ev = + updateWithLens target (handleEvent ev) + +updateWithLens :: Lens' s 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 () +updateWithLens target act = do ro <- EventM ask s <- EventM $ lift get let stInner = ES { applicationState = (applicationState s)^.target @@ -136,7 +146,7 @@ handleEventLensed target handleEvent ev = do , cacheInvalidateRequests = cacheInvalidateRequests s , requestedVisibleNames = requestedVisibleNames s } - ((), stInnerFinal) <- liftIO $ runStateT (runReaderT (runEventM (handleEvent ev)) ro) stInner + ((), stInnerFinal) <- liftIO $ runStateT (runReaderT (runEventM act) ro) stInner EventM $ lift $ put $ s { applicationState = applicationState s & target .~ applicationState stInnerFinal } -- | The monad in which event handlers run. Although it may be tempting diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs index b46eb62..4932fbd 100644 --- a/src/Brick/Widgets/FileBrowser.hs +++ b/src/Brick/Widgets/FileBrowser.hs @@ -143,7 +143,7 @@ where import qualified Control.Exception as E import Control.Monad (forM) import Control.Monad.IO.Class (liftIO) -import Control.Monad.State (get, modify) +import Control.Monad.State (put, get, modify) import Data.Char (toLower, isPrint) import Data.Maybe (fromMaybe, isJust, fromJust) import qualified Data.Foldable as F @@ -358,10 +358,10 @@ setWorkingDirectory path b = do Left (_::E.IOException) -> entries Right parent -> parent : entries - let b' = setEntries allEntries b - return $ b' & fileBrowserWorkingDirectoryL .~ path - & fileBrowserExceptionL .~ exc - & fileBrowserSelectedFilesL .~ mempty + return $ (setEntries allEntries b) + & fileBrowserWorkingDirectoryL .~ path + & fileBrowserExceptionL .~ exc + & fileBrowserSelectedFilesL .~ mempty parentOf :: FilePath -> IO FileInfo parentOf path = getFileInfo ".." $ FP.takeDirectory path @@ -609,19 +609,19 @@ actionFileBrowserSelectCurrent = actionFileBrowserListPageUp :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListPageUp = - handleEventLensed fileBrowserEntriesL listMovePageUp + updateWithLens fileBrowserEntriesL listMovePageUp actionFileBrowserListPageDown :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListPageDown = - handleEventLensed fileBrowserEntriesL listMovePageDown + updateWithLens fileBrowserEntriesL listMovePageDown actionFileBrowserListHalfPageUp :: Ord n => EventM n (FileBrowser n) () -actionFileBrowserListHalfPageUp b = - handleEventLensed fileBrowserEntriesL (listMoveByPages (-0.5::Double)) +actionFileBrowserListHalfPageUp = + updateWithLens fileBrowserEntriesL (listMoveByPages (-0.5::Double)) actionFileBrowserListHalfPageDown :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListHalfPageDown = - handleEventLensed fileBrowserEntriesL (listMoveByPages (0.5::Double)) + updateWithLens fileBrowserEntriesL (listMoveByPages (0.5::Double)) actionFileBrowserListTop :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListTop = @@ -656,14 +656,14 @@ handleFileBrowserEventSearching :: (Ord n) => Vty.Event -> EventM n (FileBrowser handleFileBrowserEventSearching e = case e of Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl] -> - return $ updateFileBrowserSearch (const Nothing) + modify $ updateFileBrowserSearch (const Nothing) Vty.EvKey Vty.KEsc [] -> - return $ updateFileBrowserSearch (const Nothing) + modify $ updateFileBrowserSearch (const Nothing) Vty.EvKey Vty.KBS [] -> - return $ updateFileBrowserSearch (fmap safeInit) - Vty.EvKey Vty.KEnter [] -> - updateFileBrowserSearch (const Nothing) <$> - maybeSelectCurrentEntry + modify $ updateFileBrowserSearch (fmap safeInit) + Vty.EvKey Vty.KEnter [] -> do + maybeSelectCurrentEntry + modify $ updateFileBrowserSearch (const Nothing) Vty.EvKey (Vty.KChar c) [] -> modify $ updateFileBrowserSearch (fmap (flip T.snoc c)) _ -> @@ -726,11 +726,11 @@ maybeSelectCurrentEntry = do then fileBrowserSelectedFilesL %= Set.insert (fileInfoFilename entry) else case fileInfoFileType entry of Just Directory -> - liftIO $ setWorkingDirectory (fileInfoFilePath entry) b + put =<< (liftIO $ setWorkingDirectory (fileInfoFilePath entry) b) Just SymbolicLink -> case fileInfoLinkTargetType entry of - Just Directory -> do - liftIO $ setWorkingDirectory (fileInfoFilePath entry) b + Just Directory -> + put =<< (liftIO $ setWorkingDirectory (fileInfoFilePath entry) b) _ -> return () _ -> From aa07f9eaee2dc8f7a0be7b2486bb3b0ab1ffb4e4 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sat, 16 Jul 2022 23:09:51 -0700 Subject: [PATCH 03/37] Finish most proof of concept internals updates for EventM changes --- src/Brick/Forms.hs | 139 ++++++++++++++++++++++++--------------------- src/Brick/Main.hs | 9 +-- src/Brick/Types.hs | 50 ++++++++++++---- 3 files changed, 115 insertions(+), 83 deletions(-) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index dc0afed..8486613 100644 --- a/src/Brick/Forms.hs +++ b/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 diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index a3cd947..d3cc651 100644 --- a/src/Brick/Main.hs +++ b/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 diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index e5910e2..c418d45 100644 --- a/src/Brick/Types.hs +++ b/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 From 4ea1f65d8624d147d97d4e11744c77f35427f83a Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sat, 16 Jul 2022 23:10:03 -0700 Subject: [PATCH 04/37] Update demo programs for changes to EventM --- brick.cabal | 38 ++++++++++++----- programs/AttrDemo.hs | 2 +- programs/CacheDemo.hs | 13 +++--- programs/CroppingDemo.hs | 2 +- programs/CustomEventDemo.hs | 22 +++++----- programs/DialogDemo.hs | 14 +++---- programs/EditDemo.hs | 28 +++++++------ programs/FileBrowserDemo.hs | 23 ++++++----- programs/FormDemo.hs | 17 ++++---- programs/LayerDemo.hs | 43 ++++++++++---------- programs/ListDemo.hs | 32 ++++++++------- programs/ListViDemo.hs | 32 ++++++++------- programs/MouseDemo.hs | 27 ++++++------- programs/PaddingDemo.hs | 2 +- programs/ProgressBarDemo.hs | 31 ++++++++------ programs/SuspendAndResumeDemo.hs | 19 +++++---- programs/TailDemo.hs | 65 ++++++++++++++++-------------- programs/ThemeDemo.hs | 16 ++++---- programs/ViewportScrollDemo.hs | 30 +++++++------- programs/ViewportScrollbarsDemo.hs | 33 ++++++++------- programs/VisibilityDemo.hs | 31 +++++++------- 21 files changed, 286 insertions(+), 234 deletions(-) diff --git a/brick.cabal b/brick.cabal index c195ed3..7c7fbe8 100644 --- a/brick.cabal +++ b/brick.cabal @@ -160,7 +160,9 @@ executable brick-tail-demo brick, text, vty, - random + random, + microlens-th, + microlens-mtl executable brick-readme-demo if !flag(demos) @@ -185,7 +187,8 @@ executable brick-file-browser-demo build-depends: base, vty, brick, - text + text, + mtl executable brick-form-demo if !flag(demos) @@ -200,6 +203,7 @@ executable brick-form-demo text, microlens, microlens-th, + mtl, vty executable brick-text-wrap-demo @@ -228,7 +232,8 @@ executable brick-cache-demo vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + mtl executable brick-visibility-demo if !flag(demos) @@ -242,7 +247,8 @@ executable brick-visibility-demo vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-viewport-scrollbars-demo if !flag(demos) @@ -256,7 +262,9 @@ executable brick-viewport-scrollbars-demo brick, vty, text, - microlens + microlens, + microlens-mtl, + microlens-th executable brick-viewport-scroll-demo if !flag(demos) @@ -298,6 +306,7 @@ executable brick-mouse-demo text, microlens >= 0.3.0.0, microlens-th, + microlens-mtl, text-zipper executable brick-layer-demo @@ -312,7 +321,8 @@ executable brick-layer-demo vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-suspend-resume-demo if !flag(demos) @@ -365,6 +375,7 @@ executable brick-theme-demo brick, vty, text, + mtl, microlens executable brick-attr-demo @@ -392,6 +403,8 @@ executable brick-list-demo vty, text, microlens >= 0.3.0.0, + microlens-mtl, + mtl, vector executable brick-list-vi-demo @@ -406,6 +419,8 @@ executable brick-list-vi-demo vty, text, microlens >= 0.3.0.0, + microlens-mtl, + mtl, vector executable brick-custom-event-demo @@ -420,7 +435,8 @@ executable brick-custom-event-demo vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-fill-demo if !flag(demos) @@ -460,8 +476,10 @@ executable brick-edit-demo vty, text, vector, + mtl, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-border-demo if !flag(demos) @@ -503,7 +521,9 @@ executable brick-progressbar-demo brick, vty, text, - microlens + microlens, + microlens-mtl, + microlens-th test-suite brick-tests type: exitcode-stdio-1.0 diff --git a/programs/AttrDemo.hs b/programs/AttrDemo.hs index e29c4ef..0bd37b4 100644 --- a/programs/AttrDemo.hs +++ b/programs/AttrDemo.hs @@ -70,7 +70,7 @@ app :: App () e () app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const theMap , appChooseCursor = neverShowCursor } diff --git a/programs/CacheDemo.hs b/programs/CacheDemo.hs index 0ca96c6..f2506c1 100644 --- a/programs/CacheDemo.hs +++ b/programs/CacheDemo.hs @@ -3,6 +3,7 @@ module Main where import Control.Monad (void) +import Control.Monad.State (modify) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif @@ -57,11 +58,11 @@ drawUi i = [ui] , str "'Esc' to quit." ] -appEvent :: Int -> BrickEvent Name e -> T.EventM Name (T.Next Int) -appEvent i (VtyEvent (V.EvKey (V.KChar '+') [])) = M.continue $ i + 1 -appEvent i (VtyEvent (V.EvKey (V.KChar 'i') [])) = M.invalidateCacheEntry ExpensiveWidget >> M.continue i -appEvent i (VtyEvent (V.EvKey V.KEsc [])) = M.halt i -appEvent i _ = M.continue i +appEvent :: BrickEvent Name e -> T.EventM Name Int () +appEvent (VtyEvent (V.EvKey (V.KChar '+') [])) = modify (+ 1) +appEvent (VtyEvent (V.EvKey (V.KChar 'i') [])) = M.invalidateCacheEntry ExpensiveWidget +appEvent (VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () emphAttr :: AttrName emphAttr = "emphasis" @@ -69,7 +70,7 @@ emphAttr = "emphasis" app :: M.App Int e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const $ attrMap V.defAttr [(emphAttr, V.white `on` V.blue)] , M.appChooseCursor = M.neverShowCursor diff --git a/programs/CroppingDemo.hs b/programs/CroppingDemo.hs index d2d722d..a5ff63d 100644 --- a/programs/CroppingDemo.hs +++ b/programs/CroppingDemo.hs @@ -52,7 +52,7 @@ app :: App () e () app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] , appChooseCursor = neverShowCursor } diff --git a/programs/CustomEventDemo.hs b/programs/CustomEventDemo.hs index 41c721f..383a9f1 100644 --- a/programs/CustomEventDemo.hs +++ b/programs/CustomEventDemo.hs @@ -3,8 +3,9 @@ {-# LANGUAGE CPP #-} module Main where -import Lens.Micro ((^.), (&), (.~), (%~)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void, forever) import Control.Concurrent (threadDelay, forkIO) #if !(MIN_VERSION_base(4,11,0)) @@ -17,7 +18,6 @@ import Brick.Main ( App(..) , showFirstCursor , customMain - , continue , halt ) import Brick.AttrMap @@ -25,7 +25,6 @@ import Brick.AttrMap ) import Brick.Types ( Widget - , Next , EventM , BrickEvent(..) ) @@ -50,14 +49,15 @@ drawUI st = [a] <=> (str $ "Counter value is: " <> (show $ st^.stCounter)) -appEvent :: St -> BrickEvent () CustomEvent -> EventM () (Next St) -appEvent st e = +appEvent :: BrickEvent () CustomEvent -> EventM () St () +appEvent e = case e of - VtyEvent (V.EvKey V.KEsc []) -> halt st - VtyEvent _ -> continue $ st & stLastBrickEvent .~ (Just e) - AppEvent Counter -> continue $ st & stCounter %~ (+1) - & stLastBrickEvent .~ (Just e) - _ -> continue st + VtyEvent (V.EvKey V.KEsc []) -> halt + VtyEvent _ -> stLastBrickEvent .= (Just e) + AppEvent Counter -> do + stCounter %= (+1) + stLastBrickEvent .= (Just e) + _ -> return () initialState :: St initialState = @@ -70,7 +70,7 @@ theApp = App { appDraw = drawUI , appChooseCursor = showFirstCursor , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] } diff --git a/programs/DialogDemo.hs b/programs/DialogDemo.hs index c1f97ad..5ff6531 100644 --- a/programs/DialogDemo.hs +++ b/programs/DialogDemo.hs @@ -30,13 +30,13 @@ drawUI d = [ui] where ui = D.renderDialog d $ C.hCenter $ padAll 1 $ str "This is the dialog body." -appEvent :: D.Dialog Choice -> BrickEvent () e -> T.EventM () (T.Next (D.Dialog Choice)) -appEvent d (VtyEvent ev) = +appEvent :: BrickEvent () e -> T.EventM () (D.Dialog Choice) () +appEvent (VtyEvent ev) = case ev of - V.EvKey V.KEsc [] -> M.halt d - V.EvKey V.KEnter [] -> M.halt d - _ -> M.continue =<< D.handleDialogEvent ev d -appEvent d _ = M.continue d + V.EvKey V.KEsc [] -> M.halt + V.EvKey V.KEnter [] -> M.halt + _ -> D.handleDialogEvent ev +appEvent _ = return () initialState :: D.Dialog Choice initialState = D.dialog (Just "Title") (Just (0, choices)) 50 @@ -58,7 +58,7 @@ theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs index b13adde..57722d0 100644 --- a/programs/EditDemo.hs +++ b/programs/EditDemo.hs @@ -5,6 +5,7 @@ module Main where import Lens.Micro import Lens.Micro.TH +import Lens.Micro.Mtl import qualified Graphics.Vty as V import qualified Brick.Main as M @@ -47,18 +48,19 @@ drawUI st = [ui] str " " <=> str "Press Tab to switch between editors, Esc to quit." -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = - M.halt st -appEvent st (T.VtyEvent (V.EvKey (V.KChar '\t') [])) = - M.continue $ st & focusRing %~ F.focusNext -appEvent st (T.VtyEvent (V.EvKey V.KBackTab [])) = - M.continue $ st & focusRing %~ F.focusPrev -appEvent st ev = - M.continue =<< case F.focusGetCurrent (st^.focusRing) of - Just Edit1 -> T.handleEventLensed st edit1 E.handleEditorEvent ev - Just Edit2 -> T.handleEventLensed st edit2 E.handleEditorEvent ev - Nothing -> return st +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = + M.halt +appEvent (T.VtyEvent (V.EvKey (V.KChar '\t') [])) = + focusRing %= F.focusNext +appEvent (T.VtyEvent (V.EvKey V.KBackTab [])) = + focusRing %= F.focusPrev +appEvent ev = do + r <- use focusRing + case F.focusGetCurrent r of + Just Edit1 -> T.handleEventLensed edit1 E.handleEditorEvent ev + Just Edit2 -> T.handleEventLensed edit2 E.handleEditorEvent ev + Nothing -> return () initialState :: St initialState = @@ -80,7 +82,7 @@ theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = appCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/FileBrowserDemo.hs b/programs/FileBrowserDemo.hs index 3df47d5..eb59c20 100644 --- a/programs/FileBrowserDemo.hs +++ b/programs/FileBrowserDemo.hs @@ -8,6 +8,7 @@ import Data.Monoid #endif import qualified Graphics.Vty as V +import Control.Monad.State (get) import qualified Data.Text as Text import qualified Brick.Main as M import qualified Brick.Widgets.List as L @@ -55,22 +56,24 @@ drawUI b = [center $ ui <=> help] , hCenter $ txt "Esc: quit" ] -appEvent :: FB.FileBrowser Name -> BrickEvent Name e -> T.EventM Name (T.Next (FB.FileBrowser Name)) -appEvent b (VtyEvent ev) = +appEvent :: BrickEvent Name e -> T.EventM Name (FB.FileBrowser Name) () +appEvent (VtyEvent ev) = do + b <- get case ev of V.EvKey V.KEsc [] | not (FB.fileBrowserIsSearching b) -> - M.halt b + M.halt _ -> do - b' <- FB.handleFileBrowserEvent ev b + FB.handleFileBrowserEvent ev -- If the browser has a selected file after handling the -- event (because the user pressed Enter), shut down. case ev of - V.EvKey V.KEnter [] -> + V.EvKey V.KEnter [] -> do + b' <- get case FB.fileBrowserSelection b' of - [] -> M.continue b' - _ -> M.halt b' - _ -> M.continue b' -appEvent b _ = M.continue b + [] -> return () + _ -> M.halt + _ -> return () +appEvent _ = return () errorAttr :: AttrName errorAttr = "error" @@ -95,7 +98,7 @@ theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/FormDemo.hs b/programs/FormDemo.hs index 5f5bac4..a053c97 100644 --- a/programs/FormDemo.hs +++ b/programs/FormDemo.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Monad.State (gets, modify) import qualified Data.Text as T import Lens.Micro ((^.)) import Lens.Micro.TH @@ -112,22 +113,24 @@ draw f = [C.vCenter $ C.hCenter form <=> C.hCenter help] app :: App (Form UserInfo e Name) e Name app = App { appDraw = draw - , appHandleEvent = \s ev -> + , appHandleEvent = \ev -> do + f <- gets formFocus case ev of - VtyEvent (V.EvResize {}) -> continue s - VtyEvent (V.EvKey V.KEsc []) -> halt s + VtyEvent (V.EvResize {}) -> return () + VtyEvent (V.EvKey V.KEsc []) -> halt -- Enter quits only when we aren't in the multi-line editor. VtyEvent (V.EvKey V.KEnter []) - | focusGetCurrent (formFocus s) /= Just AddressField -> halt s + | focusGetCurrent f /= Just AddressField -> halt _ -> do - s' <- handleFormEvent ev s + handleFormEvent ev -- Example of external validation: -- Require age field to contain a value that is at least 18. - continue $ setFieldValid ((formState s')^.age >= 18) AgeField s' + st <- gets formState + modify $ setFieldValid (st^.age >= 18) AgeField , appChooseCursor = focusRingCursor formFocus - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const theMap } diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs index 38c6f8f..7c60e34 100644 --- a/programs/LayerDemo.hs +++ b/programs/LayerDemo.hs @@ -6,8 +6,9 @@ module Main where #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif -import Lens.Micro ((^.), (&), (%~)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void) import qualified Graphics.Vty as V @@ -72,27 +73,27 @@ bottomLayer st = translateBy (st^.bottomLayerLocation) $ B.border $ str "Bottom layer\n(Ctrl-arrow keys move)" -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st (T.VtyEvent (V.EvKey V.KDown [])) = - M.continue $ st & middleLayerLocation.locationRowL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [])) = - M.continue $ st & middleLayerLocation.locationRowL %~ (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KRight [])) = - M.continue $ st & middleLayerLocation.locationColumnL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [])) = - M.continue $ st & middleLayerLocation.locationColumnL %~ (subtract 1) +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = + middleLayerLocation.locationRowL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = + middleLayerLocation.locationRowL %= (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = + middleLayerLocation.locationColumnL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = + middleLayerLocation.locationColumnL %= (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationRowL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationRowL %~ (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationColumnL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationColumnL %~ (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = + bottomLayerLocation.locationRowL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = + bottomLayerLocation.locationRowL %= (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = + bottomLayerLocation.locationColumnL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = + bottomLayerLocation.locationColumnL %= (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st -appEvent st _ = M.continue st +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () arrowAttr :: AttrName arrowAttr = "attr" @@ -100,7 +101,7 @@ arrowAttr = "attr" app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const $ attrMap V.defAttr [(arrowAttr, fg V.cyan)] , M.appChooseCursor = M.neverShowCursor diff --git a/programs/ListDemo.hs b/programs/ListDemo.hs index 4cf1741..0ff6338 100644 --- a/programs/ListDemo.hs +++ b/programs/ListDemo.hs @@ -3,7 +3,9 @@ module Main where import Lens.Micro ((^.)) +import Lens.Micro.Mtl import Control.Monad (void) +import Control.Monad.State (modify) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif @@ -48,26 +50,28 @@ drawUI l = [ui] , C.hCenter $ str "Press Esc to exit." ] -appEvent :: L.List () Char -> T.BrickEvent () e -> T.EventM () (T.Next (L.List () Char)) -appEvent l (T.VtyEvent e) = +appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Char) () +appEvent (T.VtyEvent e) = case e of - V.EvKey (V.KChar '+') [] -> - let el = nextElement (L.listElements l) - pos = Vec.length $ l^.(L.listElementsL) - in M.continue $ L.listInsert pos el l + V.EvKey (V.KChar '+') [] -> do + els <- use L.listElementsL + let el = nextElement els + pos = Vec.length els + modify $ L.listInsert pos el - V.EvKey (V.KChar '-') [] -> - case l^.(L.listSelectedL) of - Nothing -> M.continue l - Just i -> M.continue $ L.listRemove i l + V.EvKey (V.KChar '-') [] -> do + sel <- use L.listSelectedL + case sel of + Nothing -> return () + Just i -> modify $ L.listRemove i - V.EvKey V.KEsc [] -> M.halt l + V.EvKey V.KEsc [] -> M.halt - ev -> M.continue =<< L.handleListEvent ev l + ev -> L.handleListEvent ev where nextElement :: Vec.Vector Char -> Char nextElement v = fromMaybe '?' $ Vec.find (flip Vec.notElem v) (Vec.fromList ['a' .. 'z']) -appEvent l _ = M.continue l +appEvent _ = return () listDrawElement :: (Show a) => Bool -> a -> Widget () listDrawElement sel a = @@ -94,7 +98,7 @@ theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/ListViDemo.hs b/programs/ListViDemo.hs index 9da5247..0aaef35 100644 --- a/programs/ListViDemo.hs +++ b/programs/ListViDemo.hs @@ -3,12 +3,14 @@ module Main where import Control.Monad (void) +import Control.Monad.State (modify) import Data.Maybe (fromMaybe) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif import qualified Graphics.Vty as V import Lens.Micro ((^.)) +import Lens.Micro.Mtl import qualified Brick.AttrMap as A import qualified Brick.Main as M @@ -39,26 +41,28 @@ drawUI l = [ui] , C.hCenter $ str "Press Esc to exit." ] -appEvent :: L.List () Char -> T.BrickEvent () e -> T.EventM () (T.Next (L.List () Char)) -appEvent l (T.VtyEvent e) = +appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Char) () +appEvent (T.VtyEvent e) = case e of - V.EvKey (V.KChar '+') [] -> - let el = nextElement (L.listElements l) - pos = Vec.length $ l^.(L.listElementsL) - in M.continue $ L.listInsert pos el l + V.EvKey (V.KChar '+') [] -> do + els <- use L.listElementsL + let el = nextElement els + pos = Vec.length els + modify $ L.listInsert pos el - V.EvKey (V.KChar '-') [] -> - case l^.(L.listSelectedL) of - Nothing -> M.continue l - Just i -> M.continue $ L.listRemove i l + V.EvKey (V.KChar '-') [] -> do + sel <- use L.listSelectedL + case sel of + Nothing -> return () + Just i -> modify $ L.listRemove i - V.EvKey V.KEsc [] -> M.halt l + V.EvKey V.KEsc [] -> M.halt - ev -> M.continue =<< (L.handleListEventVi L.handleListEvent) ev l + ev -> L.handleListEventVi L.handleListEvent ev where nextElement :: Vec.Vector Char -> Char nextElement v = fromMaybe '?' $ Vec.find (flip Vec.notElem v) (Vec.fromList ['a' .. 'z']) -appEvent l _ = M.continue l +appEvent _ = return () listDrawElement :: (Show a) => Bool -> a -> Widget () listDrawElement sel a = @@ -85,7 +89,7 @@ theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs index 434429b..a1299a4 100644 --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -3,8 +3,9 @@ {-# LANGUAGE TemplateHaskell #-} module Main where -import Lens.Micro ((^.), (&), (.~)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) @@ -83,18 +84,16 @@ infoLayer st = T.Widget T.Fixed T.Fixed $ do withDefAttr "info" $ C.hCenter $ str msg -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st ev@(T.MouseDown n _ _ loc) = - M.continue =<< T.handleEventLensed (st & lastReportedClick .~ Just (n, loc)) - edit - E.handleEditorEvent - ev -appEvent st (T.MouseUp {}) = M.continue $ st & lastReportedClick .~ Nothing -appEvent st (T.VtyEvent (V.EvMouseUp {})) = M.continue $ st & lastReportedClick .~ Nothing -appEvent st (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) (-1) >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) 1 >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st -appEvent st ev = M.continue =<< T.handleEventLensed st edit E.handleEditorEvent ev +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent ev@(T.MouseDown n _ _ loc) = do + lastReportedClick .= Just (n, loc) + T.handleEventLensed edit E.handleEditorEvent ev +appEvent (T.MouseUp {}) = lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvMouseUp {})) = lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) 1 +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent ev = T.handleEventLensed edit E.handleEditorEvent ev aMap :: AttrMap aMap = attrMap V.defAttr @@ -108,7 +107,7 @@ aMap = attrMap V.defAttr app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const aMap , M.appChooseCursor = M.showFirstCursor diff --git a/programs/PaddingDemo.hs b/programs/PaddingDemo.hs index 1d55d65..25a7466 100644 --- a/programs/PaddingDemo.hs +++ b/programs/PaddingDemo.hs @@ -49,7 +49,7 @@ app :: App () e () app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] , appChooseCursor = neverShowCursor } diff --git a/programs/ProgressBarDemo.hs b/programs/ProgressBarDemo.hs index 2d349d2..93c4a56 100644 --- a/programs/ProgressBarDemo.hs +++ b/programs/ProgressBarDemo.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} module Main where import Control.Monad (void) @@ -7,6 +8,8 @@ import Control.Monad (void) import Data.Monoid #endif import qualified Graphics.Vty as V +import Lens.Micro.Mtl +import Lens.Micro.TH import qualified Brick.AttrMap as A import qualified Brick.Main as M @@ -23,7 +26,9 @@ import Brick.Widgets.Core ) import Brick.Util (fg, bg, on, clamp) -data MyAppState n = MyAppState { x, y, z :: Float } +data MyAppState n = MyAppState { _x, _y, _z :: Float } + +makeLenses ''MyAppState drawUI :: MyAppState () -> [Widget ()] drawUI p = [ui] @@ -33,16 +38,16 @@ drawUI p = [ui] (A.mapAttrNames [ (xDoneAttr, P.progressCompleteAttr) , (xToDoAttr, P.progressIncompleteAttr) ] - ) $ bar $ x p + ) $ bar $ _x p -- or use individual mapAttrName calls yBar = updateAttrMap (A.mapAttrName yDoneAttr P.progressCompleteAttr . A.mapAttrName yToDoAttr P.progressIncompleteAttr) $ - bar $ y p + bar $ _y p -- or use overrideAttr calls zBar = overrideAttr P.progressCompleteAttr zDoneAttr $ overrideAttr P.progressIncompleteAttr zToDoAttr $ - bar $ z p + bar $ _z p lbl c = Just $ show $ fromEnum $ c * 100 bar v = P.progressBar (lbl v) v ui = (str "X: " <+> xBar) <=> @@ -51,16 +56,16 @@ drawUI p = [ui] str "" <=> str "Hit 'x', 'y', or 'z' to advance progress, or 'q' to quit" -appEvent :: MyAppState () -> T.BrickEvent () e -> T.EventM () (T.Next (MyAppState ())) -appEvent p (T.VtyEvent e) = +appEvent :: T.BrickEvent () e -> T.EventM () (MyAppState ()) () +appEvent (T.VtyEvent e) = let valid = clamp (0.0 :: Float) 1.0 in case e of - V.EvKey (V.KChar 'x') [] -> M.continue $ p { x = valid $ x p + 0.05 } - V.EvKey (V.KChar 'y') [] -> M.continue $ p { y = valid $ y p + 0.03 } - V.EvKey (V.KChar 'z') [] -> M.continue $ p { z = valid $ z p + 0.02 } - V.EvKey (V.KChar 'q') [] -> M.halt p - _ -> M.continue p -appEvent p _ = M.continue p + V.EvKey (V.KChar 'x') [] -> x %= valid . (+ 0.05) + V.EvKey (V.KChar 'y') [] -> y %= valid . (+ 0.03) + V.EvKey (V.KChar 'z') [] -> z %= valid . (+ 0.02) + V.EvKey (V.KChar 'q') [] -> M.halt + _ -> return () +appEvent _ = return () initialState :: MyAppState () initialState = MyAppState 0.25 0.18 0.63 @@ -96,7 +101,7 @@ theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/SuspendAndResumeDemo.hs b/programs/SuspendAndResumeDemo.hs index 469d675..7dfb450 100644 --- a/programs/SuspendAndResumeDemo.hs +++ b/programs/SuspendAndResumeDemo.hs @@ -3,7 +3,7 @@ {-# LANGUAGE CPP #-} module Main where -import Lens.Micro ((.~), (^.), (&)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) import Control.Monad (void) #if !(MIN_VERSION_base(4,11,0)) @@ -13,7 +13,7 @@ import qualified Graphics.Vty as V import Brick.Main ( App(..), neverShowCursor, defaultMain - , suspendAndResume, halt, continue + , suspendAndResume, halt ) import Brick.AttrMap ( attrMap @@ -21,7 +21,6 @@ import Brick.AttrMap import Brick.Types ( Widget , EventM - , Next , BrickEvent(..) ) import Brick.Widgets.Core @@ -42,16 +41,16 @@ drawUI st = [ui] , str "(Press Esc to quit or Space to ask for input)" ] -appEvent :: St -> BrickEvent () e -> EventM () (Next St) -appEvent st (VtyEvent e) = +appEvent :: BrickEvent () e -> EventM () St () +appEvent (VtyEvent e) = case e of - V.EvKey V.KEsc [] -> halt st + V.EvKey V.KEsc [] -> halt V.EvKey (V.KChar ' ') [] -> suspendAndResume $ do putStrLn "Suspended. Please enter something and press enter to resume:" s <- getLine - return $ st & stExternalInput .~ s - _ -> continue st -appEvent st _ = continue st + return $ St { _stExternalInput = s } + _ -> return () +appEvent _ = return () initialState :: St initialState = @@ -63,7 +62,7 @@ theApp = App { appDraw = drawUI , appChooseCursor = neverShowCursor , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] } diff --git a/programs/TailDemo.hs b/programs/TailDemo.hs index cbf89b4..1e578da 100644 --- a/programs/TailDemo.hs +++ b/programs/TailDemo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where #if !(MIN_VERSION_base(4,11,0)) @@ -7,6 +8,8 @@ import Data.Monoid ((<>)) import qualified Data.Text as T import Control.Monad (void) import Control.Concurrent +import Lens.Micro.TH +import Lens.Micro.Mtl import System.Random import Brick @@ -14,6 +17,14 @@ import Brick.BChan import Brick.Widgets.Border import qualified Graphics.Vty as V +data AppState = + AppState { _textAreaHeight :: Int + , _textAreaWidth :: Int + , _textAreaContents :: [T.Text] + } + +makeLenses ''AppState + draw :: AppState -> Widget n draw st = header st <=> box st @@ -22,18 +33,18 @@ header :: AppState -> Widget n header st = padBottom (Pad 1) $ hBox [ padRight (Pad 7) $ - (str $ "Max width: " <> show (textAreaWidth st)) <=> + (str $ "Max width: " <> show (_textAreaWidth st)) <=> (str "Left(-)/Right(+)") - , (str $ "Max height: " <> show (textAreaHeight st)) <=> + , (str $ "Max height: " <> show (_textAreaHeight st)) <=> (str "Down(-)/Up(+)") ] box :: AppState -> Widget n box st = border $ - hLimit (textAreaWidth st) $ - vLimit (textAreaHeight st) $ - (renderBottomUp (txtWrap <$> textAreaContents st)) + hLimit (_textAreaWidth st) $ + vLimit (_textAreaHeight st) $ + (renderBottomUp (txtWrap <$> _textAreaContents st)) -- | Given a list of widgets, draw them bottom-up in a vertical -- arrangement, i.e., the first widget in this list will appear at the @@ -69,45 +80,39 @@ textLines = , "cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." ] -handleEvent :: AppState -> BrickEvent n CustomEvent -> EventM n (Next AppState) -handleEvent s (AppEvent (NewLine l)) = - continue $ s { textAreaContents = l : textAreaContents s } -handleEvent s (VtyEvent (V.EvKey V.KUp [])) = - continue $ s { textAreaHeight = textAreaHeight s + 1 } -handleEvent s (VtyEvent (V.EvKey V.KDown [])) = - continue $ s { textAreaHeight = max 0 $ textAreaHeight s - 1 } -handleEvent s (VtyEvent (V.EvKey V.KRight [])) = - continue $ s { textAreaWidth = textAreaWidth s + 1 } -handleEvent s (VtyEvent (V.EvKey V.KLeft [])) = - continue $ s { textAreaWidth = max 0 $ textAreaWidth s - 1 } -handleEvent s (VtyEvent (V.EvKey V.KEsc [])) = - halt s -handleEvent s _ = - continue s +handleEvent :: BrickEvent n CustomEvent -> EventM n AppState () +handleEvent (AppEvent (NewLine l)) = + textAreaContents %= (l :) +handleEvent (VtyEvent (V.EvKey V.KUp [])) = + textAreaHeight %= (+ 1) +handleEvent (VtyEvent (V.EvKey V.KDown [])) = + textAreaHeight %= max 0 . subtract 1 +handleEvent (VtyEvent (V.EvKey V.KRight [])) = + textAreaWidth %= (+ 1) +handleEvent (VtyEvent (V.EvKey V.KLeft [])) = + textAreaWidth %= max 0 . subtract 1 +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = + halt +handleEvent _ = + return () data CustomEvent = NewLine T.Text -data AppState = - AppState { textAreaHeight :: Int - , textAreaWidth :: Int - , textAreaContents :: [T.Text] - } - app :: App AppState CustomEvent () app = App { appDraw = (:[]) . draw , appChooseCursor = neverShowCursor , appHandleEvent = handleEvent , appAttrMap = const $ attrMap V.defAttr [] - , appStartEvent = return + , appStartEvent = return () } initialState :: AppState initialState = - AppState { textAreaHeight = 20 - , textAreaWidth = 40 - , textAreaContents = [] + AppState { _textAreaHeight = 20 + , _textAreaWidth = 40 + , _textAreaContents = [] } -- | Run forever, generating new lines of text for the application diff --git a/programs/ThemeDemo.hs b/programs/ThemeDemo.hs index 770af2a..613ff77 100644 --- a/programs/ThemeDemo.hs +++ b/programs/ThemeDemo.hs @@ -2,6 +2,7 @@ module Main where import Control.Monad (void) +import Control.Monad.State (put) import Graphics.Vty ( white, blue, green, yellow, black, magenta , Event(EvKey) @@ -18,7 +19,6 @@ import Brick.Types ( Widget , BrickEvent(VtyEvent) , EventM - , Next ) import Brick.Widgets.Center ( hCenter @@ -58,18 +58,18 @@ theme2 = [ (keybindingAttr, fg yellow) ] -appEvent :: Int -> BrickEvent () e -> EventM () (Next Int) -appEvent _ (VtyEvent (EvKey (KChar '1') [])) = continue 1 -appEvent _ (VtyEvent (EvKey (KChar '2') [])) = continue 2 -appEvent s (VtyEvent (EvKey (KChar 'q') [])) = halt s -appEvent s (VtyEvent (EvKey KEsc [])) = halt s -appEvent s _ = continue s +appEvent :: BrickEvent () e -> EventM () Int () +appEvent (VtyEvent (EvKey (KChar '1') [])) = put 1 +appEvent (VtyEvent (EvKey (KChar '2') [])) = put 2 +appEvent (VtyEvent (EvKey (KChar 'q') [])) = halt +appEvent (VtyEvent (EvKey KEsc [])) = halt +appEvent _ = return () app :: App Int e () app = App { appDraw = const [ui] , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = \s -> -- Note that in practice this is not ideal: we don't want -- to build an attribute from a theme every time this is diff --git a/programs/ViewportScrollDemo.hs b/programs/ViewportScrollDemo.hs index 86b85d3..020b18f 100644 --- a/programs/ViewportScrollDemo.hs +++ b/programs/ViewportScrollDemo.hs @@ -50,31 +50,31 @@ drawUi = const [ui] str "Press left and right arrow keys to scroll this viewport." ] -vp1Scroll :: M.ViewportScroll Name +vp1Scroll :: M.ViewportScroll Name s vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll Name +vp2Scroll :: M.ViewportScroll Name s vp2Scroll = M.viewportScroll VP2 -vp3Scroll :: M.ViewportScroll Name +vp3Scroll :: M.ViewportScroll Name s vp3Scroll = M.viewportScroll VP3 -appEvent :: () -> T.BrickEvent Name e -> T.EventM Name (T.Next ()) -appEvent _ (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy vp3Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy vp3Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = M.hScrollBy vp3Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = M.hScrollBy vp3Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp1Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp1Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp2Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp2Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt () -appEvent _ _ = M.continue () +appEvent :: T.BrickEvent Name e -> T.EventM Name () () +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy vp3Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy vp3Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = M.hScrollBy vp3Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = M.hScrollBy vp3Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp1Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp1Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp2Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp2Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () app :: M.App () e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const $ attrMap V.defAttr [] , M.appChooseCursor = M.neverShowCursor diff --git a/programs/ViewportScrollbarsDemo.hs b/programs/ViewportScrollbarsDemo.hs index e5bb391..f23593c 100644 --- a/programs/ViewportScrollbarsDemo.hs +++ b/programs/ViewportScrollbarsDemo.hs @@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where +import Lens.Micro.TH +import Lens.Micro.Mtl import Control.Monad (void) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) @@ -57,7 +60,9 @@ customScrollbars = data Name = VP1 | VP2 | SBClick T.ClickableScrollbarElement Name deriving (Ord, Show, Eq) -data St = St { lastClickedElement :: Maybe (T.ClickableScrollbarElement, Name) } +data St = St { _lastClickedElement :: Maybe (T.ClickableScrollbarElement, Name) } + +makeLenses ''St drawUi :: St -> [Widget Name] drawUi st = [ui] @@ -65,7 +70,7 @@ drawUi st = [ui] ui = C.center $ hLimit 70 $ vLimit 21 $ (vBox [ pair , C.hCenter (str "Last clicked scroll bar element:") - , str $ show $ lastClickedElement st + , str $ show $ _lastClickedElement st ]) pair = hBox [ padRight (T.Pad 5) $ B.border $ @@ -86,19 +91,19 @@ drawUi st = [ui] : (str <$> [ "Line " <> show i | i <- [2..55::Int] ]) ] -vp1Scroll :: M.ViewportScroll Name +vp1Scroll :: M.ViewportScroll Name s vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll Name +vp2Scroll :: M.ViewportScroll Name s vp2Scroll = M.viewportScroll VP2 -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp1Scroll 1 >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp1Scroll (-1) >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp2Scroll 1 >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp2Scroll (-1) >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st -appEvent st (T.MouseDown (SBClick el n) _ _ _) = do +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp1Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp1Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp2Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp2Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent (T.MouseDown (SBClick el n) _ _ _) = do case n of VP1 -> do let vp = M.viewportScroll VP1 @@ -119,8 +124,8 @@ appEvent st (T.MouseDown (SBClick el n) _ _ _) = do _ -> return () - M.continue $ st { lastClickedElement = Just (el, n) } -appEvent st _ = M.continue st + lastClickedElement .= Just (el, n) +appEvent _ = return () theme :: AttrMap theme = @@ -132,7 +137,7 @@ theme = app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const theme , M.appChooseCursor = M.neverShowCursor diff --git a/programs/VisibilityDemo.hs b/programs/VisibilityDemo.hs index 677941b..fadcdb5 100644 --- a/programs/VisibilityDemo.hs +++ b/programs/VisibilityDemo.hs @@ -6,6 +6,7 @@ module Main where import Control.Monad (void) import Lens.Micro import Lens.Micro.TH +import Lens.Micro.Mtl #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif @@ -93,26 +94,26 @@ drawUi st = [ui] else id return $ mkItem $ str $ "Item " <> show i <> " " -vp1Scroll :: M.ViewportScroll Name +vp1Scroll :: M.ViewportScroll Name s vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll Name +vp2Scroll :: M.ViewportScroll Name s vp2Scroll = M.viewportScroll VP2 -vp3Scroll :: M.ViewportScroll Name +vp3Scroll :: M.ViewportScroll Name s vp3Scroll = M.viewportScroll VP3 -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.continue $ st & vp3Index._1 %~ min (vp3Size^._1) . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.continue $ st & vp3Index._1 %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = M.continue $ st & vp3Index._2 %~ min (vp3Size^._1) . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = M.continue $ st & vp3Index._2 %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KDown [])) = M.continue $ st & vp1Index %~ min vp1Size . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [])) = M.continue $ st & vp1Index %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KRight [])) = M.continue $ st & vp2Index %~ min vp2Size . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [])) = M.continue $ st & vp2Index %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st -appEvent st _ = M.continue st +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = vp3Index._1 %= min (vp3Size^._1) . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = vp3Index._1 %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = vp3Index._2 %= min (vp3Size^._1) . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = vp3Index._2 %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = vp1Index %= min vp1Size . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = vp1Index %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = vp2Index %= min vp2Size . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = vp2Index %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () theMap :: AttrMap theMap = attrMap V.defAttr @@ -122,7 +123,7 @@ theMap = attrMap V.defAttr app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const theMap , M.appChooseCursor = M.neverShowCursor From a5b32407585edcd8b7e7b90c414ff4f035aec49e Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sat, 16 Jul 2022 23:13:37 -0700 Subject: [PATCH 05/37] Hide state type variable in ViewportScroll to avoid unnecessary API change --- programs/ViewportScrollDemo.hs | 6 +++--- programs/ViewportScrollbarsDemo.hs | 4 ++-- programs/VisibilityDemo.hs | 6 +++--- src/Brick/Main.hs | 25 +++++++++++++------------ 4 files changed, 21 insertions(+), 20 deletions(-) diff --git a/programs/ViewportScrollDemo.hs b/programs/ViewportScrollDemo.hs index 020b18f..faa3361 100644 --- a/programs/ViewportScrollDemo.hs +++ b/programs/ViewportScrollDemo.hs @@ -50,13 +50,13 @@ drawUi = const [ui] str "Press left and right arrow keys to scroll this viewport." ] -vp1Scroll :: M.ViewportScroll Name s +vp1Scroll :: M.ViewportScroll Name vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll Name s +vp2Scroll :: M.ViewportScroll Name vp2Scroll = M.viewportScroll VP2 -vp3Scroll :: M.ViewportScroll Name s +vp3Scroll :: M.ViewportScroll Name vp3Scroll = M.viewportScroll VP3 appEvent :: T.BrickEvent Name e -> T.EventM Name () () diff --git a/programs/ViewportScrollbarsDemo.hs b/programs/ViewportScrollbarsDemo.hs index f23593c..b082d35 100644 --- a/programs/ViewportScrollbarsDemo.hs +++ b/programs/ViewportScrollbarsDemo.hs @@ -91,10 +91,10 @@ drawUi st = [ui] : (str <$> [ "Line " <> show i | i <- [2..55::Int] ]) ] -vp1Scroll :: M.ViewportScroll Name s +vp1Scroll :: M.ViewportScroll Name vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll Name s +vp2Scroll :: M.ViewportScroll Name vp2Scroll = M.viewportScroll VP2 appEvent :: T.BrickEvent Name e -> T.EventM Name St () diff --git a/programs/VisibilityDemo.hs b/programs/VisibilityDemo.hs index fadcdb5..1ebc840 100644 --- a/programs/VisibilityDemo.hs +++ b/programs/VisibilityDemo.hs @@ -94,13 +94,13 @@ drawUi st = [ui] else id return $ mkItem $ str $ "Item " <> show i <> " " -vp1Scroll :: M.ViewportScroll Name s +vp1Scroll :: M.ViewportScroll Name vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll Name s +vp2Scroll :: M.ViewportScroll Name vp2Scroll = M.viewportScroll VP2 -vp3Scroll :: M.ViewportScroll Name s +vp3Scroll :: M.ViewportScroll Name vp3Scroll = M.viewportScroll VP3 appEvent :: T.BrickEvent Name e -> T.EventM Name St () diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index d3cc651..a4e54f7 100644 --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Brick.Main ( App(..) , defaultMain @@ -503,36 +504,36 @@ showCursorNamed name locs = -- | A viewport scrolling handle for managing the scroll state of -- viewports. -data ViewportScroll n s = +data ViewportScroll n = ViewportScroll { viewportName :: n -- ^ The name of the viewport to be controlled by -- this scrolling handle. - , hScrollPage :: Direction -> EventM n s () + , hScrollPage :: forall s. Direction -> EventM n s () -- ^ Scroll the viewport horizontally by one page in -- the specified direction. - , hScrollBy :: Int -> EventM n s () + , hScrollBy :: forall s. Int -> EventM n s () -- ^ Scroll the viewport horizontally by the -- specified number of rows or columns depending on -- the orientation of the viewport. - , hScrollToBeginning :: EventM n s () + , hScrollToBeginning :: forall s. EventM n s () -- ^ Scroll horizontally to the beginning of the -- viewport. - , hScrollToEnd :: EventM n s () + , hScrollToEnd :: forall s. EventM n s () -- ^ Scroll horizontally to the end of the viewport. - , vScrollPage :: Direction -> EventM n s () + , vScrollPage :: forall s. Direction -> EventM n s () -- ^ Scroll the viewport vertically by one page in -- the specified direction. - , vScrollBy :: Int -> EventM n s () + , vScrollBy :: forall s. Int -> EventM n s () -- ^ Scroll the viewport vertically by the specified -- number of rows or columns depending on the -- orientation of the viewport. - , vScrollToBeginning :: EventM n s () + , vScrollToBeginning :: forall s. EventM n s () -- ^ Scroll vertically to the beginning of the viewport. - , vScrollToEnd :: EventM n s () + , vScrollToEnd :: forall s. EventM n s () -- ^ Scroll vertically to the end of the viewport. - , setTop :: Int -> EventM n s () + , setTop :: forall s. Int -> EventM n s () -- ^ Set the top row offset of the viewport. - , setLeft :: Int -> EventM n s () + , setLeft :: forall s. Int -> EventM n s () -- ^ Set the left column offset of the viewport. } @@ -541,7 +542,7 @@ addScrollRequest req = EventM $ do lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s }) -- | Build a viewport scroller for the viewport with the specified name. -viewportScroll :: n -> ViewportScroll n s +viewportScroll :: n -> ViewportScroll n viewportScroll n = ViewportScroll { viewportName = n , hScrollPage = \dir -> addScrollRequest (n, HScrollPage dir) From f2f8013d63ce1e9708d3f0dd97b854241587a2ad Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sat, 16 Jul 2022 23:17:45 -0700 Subject: [PATCH 06/37] Types: re-export state monad functions as part of API --- brick.cabal | 1 - programs/FormDemo.hs | 1 - src/Brick/Forms.hs | 1 - src/Brick/Types.hs | 6 ++++++ src/Brick/Widgets/Dialog.hs | 1 - src/Brick/Widgets/Edit.hs | 2 -- src/Brick/Widgets/FileBrowser.hs | 1 - src/Brick/Widgets/List.hs | 2 +- 8 files changed, 7 insertions(+), 8 deletions(-) diff --git a/brick.cabal b/brick.cabal index 7c7fbe8..f305861 100644 --- a/brick.cabal +++ b/brick.cabal @@ -203,7 +203,6 @@ executable brick-form-demo text, microlens, microlens-th, - mtl, vty executable brick-text-wrap-demo diff --git a/programs/FormDemo.hs b/programs/FormDemo.hs index a053c97..f756ed2 100644 --- a/programs/FormDemo.hs +++ b/programs/FormDemo.hs @@ -3,7 +3,6 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Monad.State (gets, modify) import qualified Data.Text as T import Lens.Micro ((^.)) import Lens.Micro.TH diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index 8486613..1ed7544 100644 --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -86,7 +86,6 @@ 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 diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index c418d45..843db7a 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -93,6 +93,12 @@ module Brick.Types -- * Renderer internals (for benchmarking) , RenderState + + -- * Re-exports for convenience + , get + , gets + , put + , modify ) where diff --git a/src/Brick/Widgets/Dialog.hs b/src/Brick/Widgets/Dialog.hs index a12f9d0..cc3b8d4 100644 --- a/src/Brick/Widgets/Dialog.hs +++ b/src/Brick/Widgets/Dialog.hs @@ -37,7 +37,6 @@ module Brick.Widgets.Dialog where import Lens.Micro -import Control.Monad.State (modify) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif diff --git a/src/Brick/Widgets/Edit.hs b/src/Brick/Widgets/Edit.hs index 949591d..41400f2 100644 --- a/src/Brick/Widgets/Edit.hs +++ b/src/Brick/Widgets/Edit.hs @@ -48,8 +48,6 @@ import Data.Monoid import Lens.Micro import Graphics.Vty (Event(..), Key(..), Modifier(..)) -import Control.Monad.State (get, put) - import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs index 4932fbd..515a492 100644 --- a/src/Brick/Widgets/FileBrowser.hs +++ b/src/Brick/Widgets/FileBrowser.hs @@ -143,7 +143,6 @@ where import qualified Control.Exception as E import Control.Monad (forM) import Control.Monad.IO.Class (liftIO) -import Control.Monad.State (put, get, modify) import Data.Char (toLower, isPrint) import Data.Maybe (fromMaybe, isJust, fromJust) import qualified Data.Foldable as F diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs index 4b6b874..30debbf 100644 --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -79,7 +79,7 @@ import Prelude hiding (reverse, splitAt) import Control.Applicative ((<|>)) import Data.Foldable (find, toList) -import Control.Monad.State (evalState, modify, get, put) +import Control.Monad.State (evalState) import Lens.Micro ((^.), (^?), (&), (.~), (%~), _2, _head, set) import Data.Functor (($>)) From 49797717ab0cd9e28e50822bb74cf74f38abe1d8 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 09:25:13 -0700 Subject: [PATCH 07/37] Use strict state monad everywhere we use a state monad --- src/Brick/Main.hs | 2 +- src/Brick/Types.hs | 2 +- src/Brick/Types/Internal.hs | 2 +- src/Brick/Widgets/Core.hs | 2 +- src/Brick/Widgets/Internal.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index a4e54f7..0d493b4 100644 --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -53,7 +53,7 @@ where import qualified Control.Exception as E import Lens.Micro ((^.), (&), (.~), (%~), _1, _2) -import Control.Monad.State +import Control.Monad.State.Strict import Control.Monad.Reader import Control.Concurrent (forkIO, killThread) import qualified Data.Foldable as F diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index 843db7a..d58ced0 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -109,7 +109,7 @@ import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif -import Control.Monad.State.Lazy +import Control.Monad.State.Strict import Control.Monad.Reader import Graphics.Vty (Attr) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index 470f72b..840cf77 100644 --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -83,7 +83,7 @@ module Brick.Types.Internal where import Control.Monad.Reader -import Control.Monad.State.Lazy +import Control.Monad.State.Strict import Lens.Micro (_1, _2, Lens') import Lens.Micro.Mtl (use) import Lens.Micro.TH (makeLenses) diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs index ee064ed..daabed5 100644 --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -121,7 +121,7 @@ import Data.Monoid ((<>)) import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, each, to, Lens') import Lens.Micro.Mtl (use, (%=)) -import Control.Monad.State.Lazy +import Control.Monad.State.Strict import Control.Monad.Reader import qualified Data.Foldable as F import qualified Data.Text as T diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs index 5ed651d..eba0954 100644 --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -10,7 +10,7 @@ where import Lens.Micro ((^.), (&), (%~)) import Lens.Micro.Mtl ((%=)) -import Control.Monad.State.Lazy +import Control.Monad.State.Strict import Control.Monad.Reader import Data.Maybe (fromMaybe) import qualified Data.Map as M From 4297ca073e1b56b19e338bbf3dc397a5e70874aa Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 09:26:34 -0700 Subject: [PATCH 08/37] Stale import --- src/Brick/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index d58ced0..869043b 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -102,7 +102,7 @@ module Brick.Types ) where -import Lens.Micro (_1, _2, to, (^.), (&), (.~), Lens') +import Lens.Micro (_1, _2, to, (^.), Lens') import Lens.Micro.Type (Getting) import Lens.Micro.Mtl ((.=), use) import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) From 301015a930efdfaea21820081832d56900665f43 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 09:26:42 -0700 Subject: [PATCH 09/37] EventState: make fields strict --- src/Brick/Types/Internal.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index 840cf77..800111b 100644 --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -227,11 +227,11 @@ data CacheInvalidateRequest n = deriving (Ord, Eq) data EventState n s = - ES { esScrollRequests :: [(n, ScrollRequest)] - , cacheInvalidateRequests :: S.Set (CacheInvalidateRequest n) - , requestedVisibleNames :: S.Set n - , applicationState :: s - , nextAction :: NextAction s + ES { esScrollRequests :: ![(n, ScrollRequest)] + , cacheInvalidateRequests :: !(S.Set (CacheInvalidateRequest n)) + , requestedVisibleNames :: !(S.Set n) + , applicationState :: !s + , nextAction :: !(NextAction s) } -- | An extent of a named area: its size, location, and origin. From 312b7f83918509e0bdb455553be0f5f21ee7d8eb Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 09:28:16 -0700 Subject: [PATCH 10/37] Whitespace --- src/Brick/Types/Internal.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index 800111b..96ba42b 100644 --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -213,13 +213,14 @@ data Viewport = -- | The type of viewports that indicates the direction(s) in which a -- viewport is scrollable. -data ViewportType = Vertical - -- ^ Viewports of this type are scrollable only vertically. - | Horizontal - -- ^ Viewports of this type are scrollable only horizontally. - | Both - -- ^ Viewports of this type are scrollable vertically and horizontally. - deriving (Show, Eq) +data ViewportType = + Vertical + -- ^ Viewports of this type are scrollable only vertically. + | Horizontal + -- ^ Viewports of this type are scrollable only horizontally. + | Both + -- ^ Viewports of this type are scrollable vertically and horizontally. + deriving (Show, Eq) data CacheInvalidateRequest n = InvalidateSingle n From d0ffb6fbf4f9e2d4a8c3320e357b05fdb3372db9 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 09:31:43 -0700 Subject: [PATCH 11/37] Extent, Result: make fields strict --- src/Brick/Types/Internal.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index 96ba42b..68de6b4 100644 --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -236,9 +236,9 @@ data EventState n s = } -- | An extent of a named area: its size, location, and origin. -data Extent n = Extent { extentName :: n - , extentUpperLeft :: Location - , extentSize :: (Int, Int) +data Extent n = Extent { extentName :: !n + , extentUpperLeft :: !Location + , extentSize :: !(Int, Int) } deriving (Show, Read, Generic, NFData) @@ -314,15 +314,15 @@ data DynBorder = DynBorder -- result provides the image, cursor positions, and visibility requests -- that resulted from the rendering process. data Result n = - Result { image :: Image + Result { image :: !Image -- ^ The final rendered image for a widget - , cursors :: [CursorLocation n] + , cursors :: ![CursorLocation n] -- ^ The list of reported cursor positions for the -- application to choose from - , visibilityRequests :: [VisibilityRequest] + , visibilityRequests :: ![VisibilityRequest] -- ^ The list of visibility requests made by widgets rendered -- while rendering this one (used by viewports) - , extents :: [Extent n] + , extents :: ![Extent n] -- Programmer's note: we don't try to maintain the invariant that -- the size of the borders closely matches the size of the 'image' -- field. Most widgets don't need to care about borders, and so they @@ -335,7 +335,7 @@ data Result n = -- If you're writing a widget, this should make it easier for you to -- do so; but beware this lack of invariant if you are consuming -- widgets. - , borders :: BorderMap DynBorder + , borders :: !(BorderMap DynBorder) -- ^ Places where we may rewrite the edge of the image when -- placing this widget next to another one. } From 875c305ad40d77e9d1a277b143866428e7fba35b Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 16:50:54 -0700 Subject: [PATCH 12/37] handleEventLensed -> withLens (generalize API), add nestEventM --- programs/EditDemo.hs | 4 +-- programs/MouseDemo.hs | 4 +-- src/Brick/Forms.hs | 2 +- src/Brick/Types.hs | 56 ++++++++++++-------------------- src/Brick/Widgets/FileBrowser.hs | 10 +++--- 5 files changed, 30 insertions(+), 46 deletions(-) diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs index 57722d0..138199b 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.handleEventLensed edit1 E.handleEditorEvent ev - Just Edit2 -> T.handleEventLensed edit2 E.handleEditorEvent ev + Just Edit1 -> T.withLens edit1 $ E.handleEditorEvent ev + Just Edit2 -> T.withLens edit2 $ E.handleEditorEvent ev Nothing -> return () initialState :: St diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs index a1299a4..26ef3b0 100644 --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -87,13 +87,13 @@ 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.handleEventLensed edit E.handleEditorEvent ev + T.withLens edit $ E.handleEditorEvent ev appEvent (T.MouseUp {}) = lastReportedClick .= Nothing appEvent (T.VtyEvent (V.EvMouseUp {})) = lastReportedClick .= Nothing appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) (-1) appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) 1 appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt -appEvent ev = T.handleEventLensed edit E.handleEditorEvent ev +appEvent ev = T.withLens edit $ E.handleEditorEvent ev aMap :: AttrMap aMap = attrMap V.defAttr diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index 1ed7544..dc9a011 100644 --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -839,7 +839,7 @@ handleFormFieldEvent n ev = do findField (field:rest) = case field of FormField n' validate _ _ handleFunc | n == n' -> do - nextSt <- runEventMWithState st (handleFunc ev) + (nextSt, ()) <- nestEventM st (handleFunc ev) -- If the new state validates, go ahead and update -- the form state with it. case validate nextSt of diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index 869043b..f67c243 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -32,9 +32,8 @@ module Brick.Types -- * Event-handling types , EventM(..) , BrickEvent(..) - , handleEventLensed - , updateWithLens - , runEventMWithState + , withLens + , nestEventM -- * Rendering infrastructure , RenderM @@ -123,29 +122,13 @@ data Padding = Pad Int | Max -- ^ Pad up to the number of available rows or columns. --- | A convenience function for handling events intended for values --- that are targets of lenses in your application state. This function --- obtains the target value of the specified lens, invokes 'handleEvent' --- on it, and stores the resulting transformed value back in the state --- using the lens. -handleEventLensed :: Lens' s a - -- ^ The lens to use to extract and store the target - -- of the event. - -> (e -> EventM n a ()) - -- ^ The event handler. - -> e - -- ^ The event to handle. - -> EventM n s () -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 +nestEventM :: a + -- ^ The lens to use to extract and store the state mutated + -- by the action. + -> EventM n a b + -- ^ The action to run. + -> EventM n s (a, b) +nestEventM s' act = do ro <- EventM ask s <- EventM $ lift get let stInner = ES { applicationState = s' @@ -154,7 +137,7 @@ runEventMWithState s' act = do , cacheInvalidateRequests = cacheInvalidateRequests s , requestedVisibleNames = requestedVisibleNames s } - ((), stInnerFinal) <- liftIO $ runStateT (runReaderT (runEventM act) ro) stInner + (actResult, stInnerFinal) <- liftIO $ runStateT (runReaderT (runEventM act) ro) stInner (nextAct, finalSt) <- case nextAction stInnerFinal of Continue -> @@ -172,18 +155,19 @@ runEventMWithState s' act = do , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal , requestedVisibleNames = requestedVisibleNames stInnerFinal } - return finalSt + return (finalSt, actResult) -updateWithLens :: Lens' s 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 () -updateWithLens target act = do +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' <- runEventMWithState val act + (val', result) <- nestEventM val act target .= val' + return result -- | The monad in which event handlers run. Although it may be tempting -- to dig into the reader value yourself, just use diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs index 515a492..45051b0 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 = - updateWithLens fileBrowserEntriesL listMovePageUp + withLens fileBrowserEntriesL listMovePageUp actionFileBrowserListPageDown :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListPageDown = - updateWithLens fileBrowserEntriesL listMovePageDown + withLens fileBrowserEntriesL listMovePageDown actionFileBrowserListHalfPageUp :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListHalfPageUp = - updateWithLens fileBrowserEntriesL (listMoveByPages (-0.5::Double)) + withLens fileBrowserEntriesL (listMoveByPages (-0.5::Double)) actionFileBrowserListHalfPageDown :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListHalfPageDown = - updateWithLens fileBrowserEntriesL (listMoveByPages (0.5::Double)) + withLens 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 _ -> - handleEventLensed fileBrowserEntriesL handleListEvent e + withLens fileBrowserEntriesL $ handleListEvent e -- | If the browser's current entry is selectable according to -- @fileBrowserSelectable@, add it to the selection set and return. From 83015ff1acd52146ea93c637ba91fe3bfcf23f92 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 18:51:02 -0700 Subject: [PATCH 13/37] Forms: update docs --- src/Brick/Forms.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index dc9a011..16c3d43 100644 --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -141,9 +141,7 @@ data FormField a b e n = -- whether the field is currently focused, followed by the -- field state. , 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. + -- ^ An event handler for this field. } -- | A form field state accompanied by the fields that manipulate that @@ -733,8 +731,8 @@ renderFormFieldState fr (FormFieldState st _ _ fields helper concatFields) = in maybeInvalid (renderField foc st) : renderFields fs in helper $ concatFields $ renderFields fields --- | Dispatch an event to the appropriate form field and return a new --- form. This handles the following events in this order: +-- | Dispatch an event to the currently focused form field. This handles +-- the following events in this order: -- -- * On @Tab@ keypresses, this changes the focus to the next field in -- the form. From 293ba9ceba5eb6a8b8e6258b56868594f76e33c5 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 19:03:29 -0700 Subject: [PATCH 14/37] Move EventM from Brick.Types to Brick.Types.EventM, stop exporting internals of EventM --- brick.cabal | 1 + src/Brick/Main.hs | 2 +- src/Brick/Types.hs | 21 ++------------------- src/Brick/Types/EventM.hs | 28 ++++++++++++++++++++++++++++ 4 files changed, 32 insertions(+), 20 deletions(-) create mode 100644 src/Brick/Types/EventM.hs diff --git a/brick.cabal b/brick.cabal index f305861..4d02631 100644 --- a/brick.cabal +++ b/brick.cabal @@ -108,6 +108,7 @@ library other-modules: Brick.Types.Common Brick.Types.TH + Brick.Types.EventM Brick.Types.Internal Brick.Widgets.Internal diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index 0d493b4..cbd15a3 100644 --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -79,7 +79,7 @@ import Graphics.Vty import Graphics.Vty.Attributes (defAttr) import Brick.BChan (BChan, newBChan, readBChan, readBChan2, writeBChan) -import Brick.Types (EventM(..)) +import Brick.Types.EventM import Brick.Types.Internal import Brick.Widgets.Internal import Brick.AttrMap diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index f67c243..f50f5c1 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -1,9 +1,6 @@ -- | Basic types used by this library. {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Brick.Types ( -- * The Widget type @@ -30,7 +27,7 @@ module Brick.Types , ClickableScrollbarElement(..) -- * Event-handling types - , EventM(..) + , EventM , BrickEvent(..) , withLens , nestEventM @@ -104,7 +101,6 @@ 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) #endif @@ -114,6 +110,7 @@ import Graphics.Vty (Attr) import Brick.Types.TH import Brick.Types.Internal +import Brick.Types.EventM import Brick.AttrMap (AttrName, attrMapLookup) -- | The type of padding. @@ -169,20 +166,6 @@ withLens target act = do target .= val' return result --- | The monad in which event handlers run. Although it may be tempting --- to dig into the reader value yourself, just use --- 'Brick.Main.lookupViewport'. -newtype EventM n s a = - EventM { runEventM :: ReaderT (EventRO n) (StateT (EventState n s) 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 } - -- | The rendering context's current drawing attribute. attrL :: forall r n. Getting r (Context n) Attr attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) diff --git a/src/Brick/Types/EventM.hs b/src/Brick/Types/EventM.hs new file mode 100644 index 0000000..3de7759 --- /dev/null +++ b/src/Brick/Types/EventM.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +module Brick.Types.EventM + ( EventM(..) + ) +where + +import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) +import Control.Monad.Reader +import Control.Monad.State.Strict + +import Brick.Types.Internal + +-- | The monad in which event handlers run. Although it may be tempting +-- to dig into the reader value yourself, just use +-- 'Brick.Main.lookupViewport'. +newtype EventM n s a = + EventM { runEventM :: ReaderT (EventRO n) (StateT (EventState n s) 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 } + From 40f37f62a00aac81c62defdcb6dd0530f0f55867 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 19:06:00 -0700 Subject: [PATCH 15/37] withLens, nestEventM: add docs --- src/Brick/Types.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index f50f5c1..fdfa16c 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -119,6 +119,9 @@ data Padding = Pad Int | Max -- ^ Pad up to the number of available rows or columns. +-- | Given a state value and an 'EventM' that mutates that state, run +-- the specified action and return both the resulting modified state and +-- the result of the action itself. nestEventM :: a -- ^ The lens to use to extract and store the state mutated -- by the action. @@ -154,6 +157,8 @@ nestEventM s' act = do } return (finalSt, 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. From 241b599fd226bcc8c31af4c16fd017a3c90869af Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 19:07:49 -0700 Subject: [PATCH 16/37] Whitespace --- src/Brick/Types/EventM.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Brick/Types/EventM.hs b/src/Brick/Types/EventM.hs index 3de7759..16a5f32 100644 --- a/src/Brick/Types/EventM.hs +++ b/src/Brick/Types/EventM.hs @@ -25,4 +25,3 @@ 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 } - From 84924f41c15006094fc6d838229bef2ccd65c370 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 17 Jul 2022 19:08:02 -0700 Subject: [PATCH 17/37] Docstring edit --- src/Brick/Types/EventM.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Brick/Types/EventM.hs b/src/Brick/Types/EventM.hs index 16a5f32..7322c53 100644 --- a/src/Brick/Types/EventM.hs +++ b/src/Brick/Types/EventM.hs @@ -12,9 +12,7 @@ import Control.Monad.State.Strict import Brick.Types.Internal --- | The monad in which event handlers run. Although it may be tempting --- to dig into the reader value yourself, just use --- 'Brick.Main.lookupViewport'. +-- | The monad in which event handlers run. newtype EventM n s a = EventM { runEventM :: ReaderT (EventRO n) (StateT (EventState n s) IO) a } From 2838263c2212853f171d7f09d19e19f84a9bdbc9 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 21 Jul 2022 14:18:49 -0700 Subject: [PATCH 18/37] MouseDemo: whitespace --- programs/MouseDemo.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs index 26ef3b0..00925c2 100644 --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -88,12 +88,18 @@ 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 -appEvent (T.MouseUp {}) = lastReportedClick .= Nothing -appEvent (T.VtyEvent (V.EvMouseUp {})) = lastReportedClick .= Nothing -appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) (-1) -appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) 1 -appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt -appEvent ev = T.withLens edit $ E.handleEditorEvent ev +appEvent (T.MouseUp {}) = + lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvMouseUp {})) = + lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = + M.vScrollBy (M.viewportScroll Prose) (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = + M.vScrollBy (M.viewportScroll Prose) 1 +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = + M.halt +appEvent ev = + T.withLens edit $ E.handleEditorEvent ev aMap :: AttrMap aMap = attrMap V.defAttr From b0273b010946a290971b3e1ee937db55f78227e8 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 21 Jul 2022 14:22:11 -0700 Subject: [PATCH 19/37] MouseDemo: move Vty handle operations into appStartEvent --- brick.cabal | 3 ++- programs/MouseDemo.hs | 13 +++++-------- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/brick.cabal b/brick.cabal index 4d02631..1122d01 100644 --- a/brick.cabal +++ b/brick.cabal @@ -307,7 +307,8 @@ executable brick-mouse-demo microlens >= 0.3.0.0, microlens-th, microlens-mtl, - text-zipper + text-zipper, + mtl executable brick-layer-demo if !flag(demos) diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs index 00925c2..fd6e4f5 100644 --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -7,6 +7,7 @@ import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) import Lens.Micro.Mtl import Control.Monad (void) +import Control.Monad.Trans (liftIO) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif @@ -113,7 +114,9 @@ aMap = attrMap V.defAttr app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return () + , M.appStartEvent = do + vty <- M.getVtyHandle + liftIO $ V.setMode (V.outputIface vty) V.Mouse True , M.appHandleEvent = appEvent , M.appAttrMap = const aMap , M.appChooseCursor = M.showFirstCursor @@ -121,13 +124,7 @@ app = main :: IO () main = do - let buildVty = do - v <- V.mkVty =<< V.standardIOConfig - V.setMode (V.outputIface v) V.Mouse True - return v - - initialVty <- buildVty - void $ M.customMain initialVty buildVty Nothing app $ St [] Nothing + void $ M.defaultMain app $ St [] Nothing (unlines [ "Try clicking on various UI elements." , "Observe that the click coordinates identify the" , "underlying widget coordinates." From f2b2586d53e678c14e8209af77e30acac71fdc25 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Fri, 22 Jul 2022 15:50:06 -0700 Subject: [PATCH 20/37] Comment edit --- src/Brick/Types.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index fdfa16c..e223eb4 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -123,8 +123,7 @@ data Padding = Pad Int -- the specified action and return both the resulting modified state and -- the result of the action itself. nestEventM :: a - -- ^ The lens to use to extract and store the state mutated - -- by the action. + -- ^ The initial state to use in the nested action. -> EventM n a b -- ^ The action to run. -> EventM n s (a, b) From bf2f6be8700b749d16b9f24f5f8f5a3b50eb6710 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Fri, 22 Jul 2022 16:07:00 -0700 Subject: [PATCH 21/37] Move Padding type from Brick.Types to Brick.Widgets.Core --- programs/CacheDemo.hs | 5 +++-- programs/CroppingDemo.hs | 2 +- programs/FileBrowserDemo.hs | 3 ++- programs/MouseDemo.hs | 2 +- programs/PaddingDemo.hs | 2 +- programs/ViewportScrollbarsDemo.hs | 5 +++-- src/Brick/Types.hs | 7 ------- src/Brick/Widgets/Core.hs | 7 +++++++ 8 files changed, 18 insertions(+), 15 deletions(-) diff --git a/programs/CacheDemo.hs b/programs/CacheDemo.hs index f2506c1..d84872d 100644 --- a/programs/CacheDemo.hs +++ b/programs/CacheDemo.hs @@ -17,7 +17,8 @@ import Brick.Types , BrickEvent(..) ) import Brick.Widgets.Core - ( vBox + ( Padding(..) + , vBox , padTopBottom , withDefAttr , cached @@ -51,7 +52,7 @@ drawUi i = [ui] , padTopBottom 1 $ cached ExpensiveWidget $ withDefAttr emphAttr $ str $ "This widget is cached (state = " <> show i <> ")" - , padBottom (T.Pad 1) $ + , padBottom (Pad 1) $ withDefAttr emphAttr $ str $ "This widget is not cached (state = " <> show i <> ")" , hCenter $ str "Press 'i' to invalidate the cache," , str "'+' to change the state value, and" diff --git a/programs/CroppingDemo.hs b/programs/CroppingDemo.hs index a5ff63d..e8fc139 100644 --- a/programs/CroppingDemo.hs +++ b/programs/CroppingDemo.hs @@ -4,7 +4,6 @@ module Main where import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) import Brick.Types ( Widget - , Padding(..) ) import Brick.Widgets.Core ( vBox @@ -20,6 +19,7 @@ import Brick.Widgets.Core , cropRightTo , cropTopTo , cropBottomTo + , Padding(..) ) import Brick.Widgets.Border (border) import Brick.AttrMap (attrMap) diff --git a/programs/FileBrowserDemo.hs b/programs/FileBrowserDemo.hs index eb59c20..11a58ec 100644 --- a/programs/FileBrowserDemo.hs +++ b/programs/FileBrowserDemo.hs @@ -28,6 +28,7 @@ import Brick.Widgets.Core ( vBox, (<=>), padTop , hLimit, vLimit, txt , withDefAttr, emptyWidget + , Padding(..) ) import qualified Brick.Widgets.FileBrowser as FB import qualified Brick.AttrMap as A @@ -45,7 +46,7 @@ drawUI b = [center $ ui <=> help] hLimit 50 $ borderWithLabel (txt "Choose a file") $ FB.renderFileBrowser True b - help = padTop (T.Pad 1) $ + help = padTop (Pad 1) $ vBox [ case FB.fileBrowserException b of Nothing -> emptyWidget Just e -> hCenter $ withDefAttr errorAttr $ diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs index fd6e4f5..179dcb7 100644 --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -45,7 +45,7 @@ drawUi st = buttonLayer :: St -> Widget Name buttonLayer st = C.vCenterLayer $ - C.hCenterLayer (padBottom (T.Pad 1) $ str "Click a button:") <=> + C.hCenterLayer (padBottom (Pad 1) $ str "Click a button:") <=> C.hCenterLayer (hBox $ padLeftRight 1 <$> buttons) <=> C.hCenterLayer (padTopBottom 1 $ str "Or enter text and then click in this editor:") <=> C.hCenterLayer (vLimit 3 $ hLimit 50 $ E.renderEditor (str . unlines) True (st^.edit)) diff --git a/programs/PaddingDemo.hs b/programs/PaddingDemo.hs index 25a7466..2c3730b 100644 --- a/programs/PaddingDemo.hs +++ b/programs/PaddingDemo.hs @@ -4,7 +4,6 @@ module Main where import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) import Brick.Types ( Widget - , Padding(..) ) import Brick.Widgets.Core ( vBox @@ -17,6 +16,7 @@ import Brick.Widgets.Core , padBottom , padTopBottom , padLeftRight + , Padding(..) ) import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Center as C diff --git a/programs/ViewportScrollbarsDemo.hs b/programs/ViewportScrollbarsDemo.hs index b082d35..b514066 100644 --- a/programs/ViewportScrollbarsDemo.hs +++ b/programs/ViewportScrollbarsDemo.hs @@ -29,7 +29,8 @@ import Brick.AttrMap , attrMap ) import Brick.Widgets.Core - ( hLimit + ( Padding(..) + , hLimit , vLimit , padRight , hBox @@ -72,7 +73,7 @@ drawUi st = [ui] , C.hCenter (str "Last clicked scroll bar element:") , str $ show $ _lastClickedElement st ]) - pair = hBox [ padRight (T.Pad 5) $ + pair = hBox [ padRight (Pad 5) $ B.border $ withClickableHScrollBars SBClick $ withHScrollBars OnBottom $ diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index e223eb4..ff174fb 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -84,7 +84,6 @@ module Brick.Types -- * Miscellaneous , Size(..) - , Padding(..) , Direction(..) -- * Renderer internals (for benchmarking) @@ -113,12 +112,6 @@ import Brick.Types.Internal import Brick.Types.EventM import Brick.AttrMap (AttrName, attrMapLookup) --- | The type of padding. -data Padding = Pad Int - -- ^ Pad by the specified number of rows or columns. - | Max - -- ^ Pad up to the number of available rows or columns. - -- | Given a state value and an 'EventM' that mutates that state, run -- the specified action and return both the resulting modified state and -- the result of the action itself. diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs index daabed5..6d80dc9 100644 --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -22,6 +22,7 @@ module Brick.Widgets.Core , hyperlink -- * Padding + , Padding(..) , padLeft , padRight , padTop @@ -375,6 +376,12 @@ hyperlink url p = let attr = (c^.attrL) `V.withURL` url withReaderT (ctxAttrMapL %~ setDefaultAttr attr) (render p) +-- | The type of padding. +data Padding = Pad Int + -- ^ Pad by the specified number of rows or columns. + | Max + -- ^ Pad up to the number of available rows or columns. + -- | Pad the specified widget on the left. If max padding is used, this -- grows greedily horizontally; otherwise it defers to the padded -- widget. From 3a6f13075655f544715075def59ee9dad500abfe Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 24 Jul 2022 07:38:30 -0700 Subject: [PATCH 22/37] Brick.Types: add nestEventM' and withFirst --- src/Brick/Types.hs | 31 +++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index fdfa16c..d0f5e75 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -30,7 +30,9 @@ module Brick.Types , EventM , BrickEvent(..) , withLens + , withFirst , nestEventM + , nestEventM' -- * Rendering infrastructure , RenderM @@ -98,9 +100,9 @@ module Brick.Types ) where -import Lens.Micro (_1, _2, to, (^.), Lens') +import Lens.Micro (_1, _2, to, (^.), Lens', Traversal') import Lens.Micro.Type (Getting) -import Lens.Micro.Mtl ((.=), use) +import Lens.Micro.Mtl ((.=), (<~), preuse, use) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif @@ -119,6 +121,16 @@ data Padding = Pad Int | Max -- ^ Pad up to the number of available rows or columns. +-- | Given a state value and an 'EventM' that mutates that state, run +-- the specified action and return resulting modified state. +nestEventM' :: a + -- ^ The lens to use to extract and store the state mutated + -- by the action. + -> EventM n a b + -- ^ The action to run. + -> EventM n s a +nestEventM' s act = fst <$> nestEventM s act + -- | Given a state value and an 'EventM' that mutates that state, run -- the specified action and return both the resulting modified state and -- the result of the action itself. @@ -171,6 +183,21 @@ withLens target act = do 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 + -- | The rendering context's current drawing attribute. attrL :: forall r n. Getting r (Context n) Attr attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) From 34f77c4bb7a370769bf6f641b5acf7c15fb519b5 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 24 Jul 2022 07:39:52 -0700 Subject: [PATCH 23/37] Comment nit --- src/Brick/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index de1600b..5487e51 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -26,7 +26,7 @@ module Brick.Types , ScrollbarRenderer(..) , ClickableScrollbarElement(..) - -- * Event-handling types + -- * Event-handling types and functions , EventM , BrickEvent(..) , withLens From 936d1662905d5d80faa9445eb2edfefccc603db5 Mon Sep 17 00:00:00 2001 From: Aaron VonderHaar Date: Mon, 25 Jul 2022 23:30:53 -0700 Subject: [PATCH 24/37] Update documentation for wide character support --- docs/guide.rst | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/docs/guide.rst b/docs/guide.rst index d8e68d9..b31a9e9 100644 --- a/docs/guide.rst +++ b/docs/guide.rst @@ -924,9 +924,11 @@ Wide Character Support and the TextWidth class Brick supports rendering wide characters in all widgets, and the brick editor supports entering and editing wide characters. Wide characters are those such as many Asian characters and emoji that need more than -a single terminal column to be displayed. Brick relies on Vty's use of -the `utf8proc`_ library to determine the column width of each character -rendered. +a single terminal column to be displayed. Brick relies on +`vty's multi-column character support`_ to determine the column width of +each character rendered, but this requires some additional +configuration. Read the details there to configure the correct widths +for your terminal. As a result of supporting wide characters, it is important to know that computing the length of a string to determine its screen width will @@ -945,8 +947,8 @@ will not be counted properly. In order to get this right, use the let width = Brick.Widgets.Core.textWidth t -The ``TextWidth`` type class uses Vty's character width routine (and -thus ``utf8proc``) to compute the correct width. If you need to compute +The ``TextWidth`` type class uses Vty's character width routine +to compute the correct width. If you need to compute the width of a single character, use ``Graphics.Text.wcwidth``. Extents @@ -1921,7 +1923,7 @@ or ``mapAttrNames`` to convert its custom names to the names that the sub-widget uses for rendering its output. .. _vty: https://github.com/jtdaugherty/vty +.. _vty's multi-column character support: https://github.com/jtdaugherty/vty#multi-column-character-support .. _Hackage: http://hackage.haskell.org/ .. _microlens: http://hackage.haskell.org/package/microlens .. _bracketed paste mode: https://cirw.in/blog/bracketed-paste -.. _utf8proc: http://julialang.org/utf8proc/ From 0b6b56282199075ebcfda1859c2f7451c25edda2 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Tue, 26 Jul 2022 08:56:48 -0700 Subject: [PATCH 25/37] Fix comment --- src/Brick/Types.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index 5487e51..e747f36 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -117,8 +117,7 @@ import Brick.AttrMap (AttrName, attrMapLookup) -- | Given a state value and an 'EventM' that mutates that state, run -- the specified action and return resulting modified state. nestEventM' :: a - -- ^ The lens to use to extract and store the state mutated - -- by the action. + -- ^ The initial state to use in the nested action. -> EventM n a b -- ^ The action to run. -> EventM n s a From e0c70f070a8cbf8f8d385c09cbea877089895b74 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Tue, 26 Jul 2022 19:03:47 -0700 Subject: [PATCH 26/37] 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. --- src/Brick/Main.hs | 154 +++++++++++++++++++++++------------- src/Brick/Types.hs | 18 ++--- src/Brick/Types/EventM.hs | 4 + src/Brick/Types/Internal.hs | 17 ++-- 4 files changed, 121 insertions(+), 72 deletions(-) diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index cbd15a3..eccc8d1 100644 --- 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 diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index e747f36..69bdefc 100644 --- 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. diff --git a/src/Brick/Types/EventM.hs b/src/Brick/Types/EventM.hs index 7322c53..bc97f03 100644 --- 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 diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index 68de6b4..d4553e6 100644 --- 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 } From dee90efa8cde1755f435c1f7dd9b6828b1bd0089 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Tue, 26 Jul 2022 19:49:29 -0700 Subject: [PATCH 27/37] 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 | 4 +- programs/MouseDemo.hs | 4 +- src/Brick/Main.hs | 27 +++++++------- src/Brick/Types.hs | 64 +++++++++----------------------- src/Brick/Types/EventM.hs | 17 +++++++-- src/Brick/Types/Internal.hs | 3 +- src/Brick/Widgets/FileBrowser.hs | 10 ++--- 7 files changed, 53 insertions(+), 76 deletions(-) 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. From 8baa49f29b4f92e3211e754386e2764ef378de32 Mon Sep 17 00:00:00 2001 From: Aaron VonderHaar Date: Wed, 27 Jul 2022 21:03:46 -0700 Subject: [PATCH 28/37] Update documentation on wide character support to clarify the current recommendation --- FAQ.md | 20 ++++++++++++++++++++ docs/guide.rst | 19 ++++++++++--------- 2 files changed, 30 insertions(+), 9 deletions(-) diff --git a/FAQ.md b/FAQ.md index 1441834..3e2fc57 100644 --- a/FAQ.md +++ b/FAQ.md @@ -7,3 +7,23 @@ brick FAQ default and requires configuration to make it work. See also: http://unix.stackexchange.com/questions/110022/how-do-i-find-out-the-keycodes-for-ctrlup-and-down-arrow-for-term-screen + +* Q: Why do some emojis mess up the layout? +* A: For wide characters to be displayed correctly, [vty]'s + determination of the character width and the user's + terminal emulator's determination of the character width + must match. Unforunately, every terminal emulator + calulcates this differently, and none correctly follow + the Unicode standard. + The issue is further complicated by Unicode combining + characters and releases of new versions of the Unicode + standard. + + As a result, the current recommendation is to avoid + use of wide characters due to these issues. + If you still must use them, you can read [vty]'s + documentation for options that will affect character + width calculations. + + +[vty]: https://hackage.haskell.org/package/vty diff --git a/docs/guide.rst b/docs/guide.rst index b31a9e9..c3d7b5b 100644 --- a/docs/guide.rst +++ b/docs/guide.rst @@ -921,14 +921,16 @@ with ``Brick.Themes.saveCustomizations``. Wide Character Support and the TextWidth class ============================================== -Brick supports rendering wide characters in all widgets, and the brick -editor supports entering and editing wide characters. Wide characters -are those such as many Asian characters and emoji that need more than -a single terminal column to be displayed. Brick relies on -`vty's multi-column character support`_ to determine the column width of -each character rendered, but this requires some additional -configuration. Read the details there to configure the correct widths -for your terminal. +Brick attempts to support rendering wide characters in all widgets, +and the brick editor supports entering and editing wide characters. +Wide characters are those such as many Asian characters and emoji +that need more than a single terminal column to be displayed. + +Unfortunatley, there is not a fully correct solution to determining +the character width that the user's terminal will use for a given +character. The current recommendation is to avoid use of wide characters +due to these issues. If you still must use them, you can read `vty`_'s +documentation for options that will affect character width calculations. As a result of supporting wide characters, it is important to know that computing the length of a string to determine its screen width will @@ -1923,7 +1925,6 @@ or ``mapAttrNames`` to convert its custom names to the names that the sub-widget uses for rendering its output. .. _vty: https://github.com/jtdaugherty/vty -.. _vty's multi-column character support: https://github.com/jtdaugherty/vty#multi-column-character-support .. _Hackage: http://hackage.haskell.org/ .. _microlens: http://hackage.haskell.org/package/microlens .. _bracketed paste mode: https://cirw.in/blog/bracketed-paste From 896e7243ef1092093cea7fe23e828995f7407ea1 Mon Sep 17 00:00:00 2001 From: Fraser Tweedale Date: Thu, 28 Jul 2022 23:34:32 +1000 Subject: [PATCH 29/37] add listSelectedElementL Traversal Add a `Traversal` that targets the selected element (if any). It is useful for retrieving, setting, modifying or traversing the selected element and composes with other optics. Asymptotics are documented. It also makes it possible to rewrite some other functions in terms of `listSelectedElementL`, including: - `listModify`: Improved asymptotics for some containers, including `Seq`. Introduces `Splittable` and `Semigroup` constraint. - `listSelectedElement`: Simplifies definition. Asymptotics unchanged. Introduces `Semigroup` constraint. Such changes are left for discussion of possible subsequent implementation. --- src/Brick/Widgets/List.hs | 28 +++++++++++++++++++++++++++- tests/List.hs | 18 +++++++++++++++++- 2 files changed, 44 insertions(+), 2 deletions(-) diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs index f950f49..68f226d 100644 --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -37,6 +37,7 @@ module Brick.Widgets.List , listSelectedL , listNameL , listItemHeightL + , listSelectedElementL -- * Accessors , listElements @@ -81,7 +82,7 @@ import Control.Applicative ((<|>)) import Data.Foldable (find, toList) import Control.Monad.Trans.State (evalState, get, put) -import Lens.Micro ((^.), (^?), (&), (.~), (%~), _2, _head, set) +import Lens.Micro (Traversal', (^.), (^?), (&), (.~), (%~), _2, _head, set) import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (fromMaybe) @@ -602,6 +603,31 @@ listFindBy test l = result = tailResult <|> headResult in maybe id (set listSelectedL . Just . fst) result l +-- | Traversal that targets the selected element, if any. +-- +-- Complexity: depends on usage as well as container type +-- +-- @ +-- listSelectedElementL for 'List': O(1) -- preview, fold +-- O(n) -- set, modify, traverse +-- listSelectedElementL for 'Seq.Seq': O(log(min(i, n - i))) -- all operations +-- @ +-- +listSelectedElementL + :: (Splittable t, Traversable t, Semigroup (t e)) + => Traversal' (GenericList n t e) e +listSelectedElementL f l = + case l ^. listSelectedL of + Nothing -> pure l + Just i -> listElementsL go l + where + go l' = + let + (left, rest) = splitAt i l' + -- middle contains the target element (if any) + (middle, right) = splitAt 1 rest + in fmap (\m -> left <> m <> right) (traverse f middle) + -- | Return a list's selected element, if any. -- -- Only evaluates as much of the container as needed. diff --git a/tests/List.hs b/tests/List.hs index ec0a418..ea83ddf 100644 --- a/tests/List.hs +++ b/tests/List.hs @@ -356,7 +356,7 @@ prop_reverseAppend_Seq l1 l2 = -- whole container to be evaluated. -- newtype L a = L [a] - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable, Semigroup) instance Splittable L where splitAt i (L xs) = over both L (Data.List.splitAt i xs) @@ -383,6 +383,22 @@ prop_findByLazy = l' ^. listSelectedL == Just 1 && l'' ^. listSelectedL == Just 3 +prop_listSelectedElement_lazy :: Bool +prop_listSelectedElement_lazy = + let + v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Just 3 + in + listSelectedElement l == Just (3, 4) + +prop_listSelectedElementL_lazy :: Bool +prop_listSelectedElementL_lazy = + let + v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Just 3 + in + over listSelectedElementL (*2) l ^? listSelectedElementL == Just 8 + return [] From dd8958fc45d9c3eea51a93cd91ca920071381f06 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 28 Jul 2022 13:02:53 -0700 Subject: [PATCH 30/37] listSelectedElementL: style --- src/Brick/Widgets/List.hs | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs index 68f226d..45afec0 100644 --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -605,7 +605,7 @@ listFindBy test l = -- | Traversal that targets the selected element, if any. -- --- Complexity: depends on usage as well as container type +-- Complexity: depends on usage as well as the list's container type. -- -- @ -- listSelectedElementL for 'List': O(1) -- preview, fold @@ -613,20 +613,17 @@ listFindBy test l = -- listSelectedElementL for 'Seq.Seq': O(log(min(i, n - i))) -- all operations -- @ -- -listSelectedElementL - :: (Splittable t, Traversable t, Semigroup (t e)) - => Traversal' (GenericList n t e) e +listSelectedElementL :: (Splittable t, Traversable t, Semigroup (t e)) + => Traversal' (GenericList n t e) e listSelectedElementL f l = - case l ^. listSelectedL of - Nothing -> pure l - Just i -> listElementsL go l - where - go l' = - let - (left, rest) = splitAt i l' - -- middle contains the target element (if any) - (middle, right) = splitAt 1 rest - in fmap (\m -> left <> m <> right) (traverse f middle) + case l ^. listSelectedL of + Nothing -> pure l + Just i -> listElementsL go l + where + go l' = let (left, rest) = splitAt i l' + -- middle contains the target element (if any) + (middle, right) = splitAt 1 rest + in (\m -> left <> m <> right) <$> (traverse f middle) -- | Return a list's selected element, if any. -- From 408129d825f1291646b650e1f282f4d4dfbc4760 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 28 Jul 2022 13:09:01 -0700 Subject: [PATCH 31/37] tests/List.hs: style --- tests/List.hs | 350 ++++++++++++++++++++++---------------------------- 1 file changed, 154 insertions(+), 196 deletions(-) diff --git a/tests/List.hs b/tests/List.hs index ea83ddf..28558eb 100644 --- a/tests/List.hs +++ b/tests/List.hs @@ -4,11 +4,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} - module List - ( - main - ) where + ( main + ) +where import Prelude hiding (reverse, splitAt) @@ -29,57 +28,56 @@ import Brick.Util (clamp) import Brick.Widgets.List instance (Arbitrary n, Arbitrary a) => Arbitrary (List n a) where - arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1 - + arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1 -- List move operations that never modify the underlying list -data ListMoveOp a - = MoveUp - | MoveDown - | MoveBy Int - | MoveTo Int - | MoveToElement a - | FindElement a - deriving (Show) +data ListMoveOp a = + MoveUp + | MoveDown + | MoveBy Int + | MoveTo Int + | MoveToElement a + | FindElement a + deriving (Show) instance Arbitrary a => Arbitrary (ListMoveOp a) where - arbitrary = oneof - [ pure MoveUp - , pure MoveDown - , MoveBy <$> arbitrary - , MoveTo <$> arbitrary - , MoveToElement <$> arbitrary - , FindElement <$> arbitrary - ] + arbitrary = + oneof [ pure MoveUp + , pure MoveDown + , MoveBy <$> arbitrary + , MoveTo <$> arbitrary + , MoveToElement <$> arbitrary + , FindElement <$> arbitrary + ] -- List operations. We don't have "page"-based movement operations -- because these depend on render context (i.e. effect in EventM) -data ListOp a - = Insert Int a - | Remove Int - | Replace Int [a] - | Clear - | Reverse - | ListMoveOp (ListMoveOp a) - deriving (Show) +data ListOp a = + Insert Int a + | Remove Int + | Replace Int [a] + | Clear + | Reverse + | ListMoveOp (ListMoveOp a) + deriving (Show) instance Arbitrary a => Arbitrary (ListOp a) where - arbitrary = frequency - [ (1, Insert <$> arbitrary <*> arbitrary) - , (1, Remove <$> arbitrary) - , (1, Replace <$> arbitrary <*> arbitrary) - , (1, pure Clear) - , (1, pure Reverse) - , (6, arbitrary) - ] + arbitrary = + frequency [ (1, Insert <$> arbitrary <*> arbitrary) + , (1, Remove <$> arbitrary) + , (1, Replace <$> arbitrary <*> arbitrary) + , (1, pure Clear) + , (1, pure Reverse) + , (6, arbitrary) + ] -- Turn a ListOp into a List endomorphism op :: Eq a => ListOp a -> List n a -> List n a op (Insert i a) = listInsert i a op (Remove i) = listRemove i op (Replace i xs) = - -- avoid setting index to Nothing - listReplace (V.fromList xs) (Just i) + -- avoid setting index to Nothing + listReplace (V.fromList xs) (Just i) op Clear = listClear op Reverse = listReverse op (ListMoveOp mo) = moveOp mo @@ -93,63 +91,61 @@ moveOp (MoveTo n) = listMoveTo n moveOp (MoveToElement a) = listMoveToElement a moveOp (FindElement a) = listFindBy (== a) -applyListOps - :: (Foldable t) - => (op a -> List n a -> List n a) -> t (op a) -> List n a -> List n a +applyListOps :: (Foldable t) + => (op a -> List n a -> List n a) + -> t (op a) + -> List n a + -> List n a applyListOps f = appEndo . foldMap (Endo . f) - -- | Initial selection is always 0 (or Nothing for empty list) prop_initialSelection :: [a] -> Bool prop_initialSelection xs = - list () (V.fromList xs) 1 ^. listSelectedL == - if null xs then Nothing else Just 0 + list () (V.fromList xs) 1 ^. listSelectedL == + if null xs then Nothing else Just 0 -- list operations keep the selected index in bounds -prop_listOpsMaintainSelectedValid - :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_listOpsMaintainSelectedValid :: (Eq a) + => [ListOp a] + -> List n a + -> Bool prop_listOpsMaintainSelectedValid ops l = - let l' = applyListOps op ops l - in - case l' ^. listSelectedL of - -- either there is no selection and list is empty - Nothing -> null l' - -- or the selected index is valid - Just i -> i >= 0 && i < length l' + let l' = applyListOps op ops l + in case l' ^. listSelectedL of + -- either there is no selection and list is empty + Nothing -> null l' + -- or the selected index is valid + Just i -> i >= 0 && i < length l' -- reversing a list keeps the selected element the same -prop_reverseMaintainsSelectedElement - :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_reverseMaintainsSelectedElement :: (Eq a) + => [ListOp a] + -> List n a + -> Bool prop_reverseMaintainsSelectedElement ops l = - let -- apply some random list ops to (probably) set a selected element - l' = applyListOps op ops l - l'' = listReverse l' - in - fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'') + let l' = applyListOps op ops l + l'' = listReverse l' + in fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'') -- reversing maintains size of list prop_reverseMaintainsSizeOfList :: List n a -> Bool prop_reverseMaintainsSizeOfList l = - length l == length (listReverse l) + length l == length (listReverse l) -- an inserted element may always be found at the given index -- (when target index is clamped to 0 <= n <= len) prop_insert :: (Eq a) => Int -> a -> List n a -> Bool prop_insert i a l = - let - l' = listInsert i a l - i' = clamp 0 (length l) i - in - listSelectedElement (listMoveTo i' l') == Just (i', a) + let l' = listInsert i a l + i' = clamp 0 (length l) i + in listSelectedElement (listMoveTo i' l') == Just (i', a) -- inserting anywhere always increases size of list by 1 prop_insertSize :: (Eq a) => Int -> a -> List n a -> Bool prop_insertSize i a l = - let - l' = listInsert i a l - in - length l' == length l + 1 + let l' = listInsert i a l + in length l' == length l + 1 -- inserting an element and moving to it always succeeds and -- the selected element is the one we inserted. @@ -160,11 +156,9 @@ prop_insertSize i a l = -- prop_insertMoveTo :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool prop_insertMoveTo ops l i a = - let - l' = listInsert i a (applyListOps op ops l) - sel = listSelectedElement (listMoveToElement a l') - in - fmap snd sel == Just a + let l' = listInsert i a (applyListOps op ops l) + sel = listSelectedElement (listMoveToElement a l') + in fmap snd sel == Just a -- inserting an element and repeatedly seeking it always -- reaches the element we inserted, at the index where we @@ -172,47 +166,38 @@ prop_insertMoveTo ops l i a = -- prop_insertFindBy :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool prop_insertFindBy ops l i a = - let - l' = applyListOps op ops l - l'' = set listSelectedL Nothing . listInsert i a $ l' - seeks = converging ((==) `on` (^. listSelectedL)) (listFindBy (== a)) l'' - i' = clamp 0 (length l') i -- we can't have inserted past len - in - (find ((== Just i') . (^. listSelectedL)) seeks >>= listSelectedElement) - == Just (i', a) + let l' = applyListOps op ops l + l'' = set listSelectedL Nothing . listInsert i a $ l' + seeks = converging ((==) `on` (^. listSelectedL)) (listFindBy (== a)) l'' + i' = clamp 0 (length l') i -- we can't have inserted past len + in (find ((== Just i') . (^. listSelectedL)) seeks >>= listSelectedElement) == Just (i', a) -- inserting then deleting always yields a list with the original elems prop_insertRemove :: (Eq a) => Int -> a -> List n a -> Bool prop_insertRemove i a l = - let - i' = clamp 0 (length l) i - l' = listInsert i' a l -- pre-clamped - l'' = listRemove i' l' - in - l'' ^. listElementsL == l ^. listElementsL + let i' = clamp 0 (length l) i + l' = listInsert i' a l -- pre-clamped + l'' = listRemove i' l' + in l'' ^. listElementsL == l ^. listElementsL -- deleting in-bounds always reduces size of list by 1 -- deleting out-of-bounds never changes list size prop_remove :: Int -> List n a -> Bool prop_remove i l = - let - len = length l - i' = clamp 0 (len - 1) i - test - | len > 0 && i == i' = (== len - 1) -- i is in bounds - | otherwise = (== len) -- i is out of bounds - in - test (length (listRemove i l)) + let len = length l + i' = clamp 0 (len - 1) i + test + | len > 0 && i == i' = (== len - 1) -- i is in bounds + | otherwise = (== len) -- i is out of bounds + in test (length (listRemove i l)) -- deleting an element and re-inserting it at same position -- gives the original list elements prop_removeInsert :: (Eq a) => Int -> List n a -> Bool prop_removeInsert i l = - let - sel = listSelectedElement (listMoveTo i l) - l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l - in - l' ^. listElementsL == l ^. listElementsL + let sel = listSelectedElement (listMoveTo i l) + l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l + in l' ^. listElementsL == l ^. listElementsL -- Apply @f@ until @test a (f a) == True@, then return @a@. converge :: (a -> a -> Bool) -> (a -> a) -> a -> a @@ -222,64 +207,57 @@ converge test f = last . converging test f -- intermediate and final values as a list. converging :: (a -> a -> Bool) -> (a -> a) -> a -> [a] converging test f a - | test a (f a) = [a] - | otherwise = a : converging test f (f a) + | test a (f a) = [a] + | otherwise = a : converging test f (f a) -- listMoveUp always reaches 0 (or list is empty) prop_moveUp :: (Eq a) => [ListOp a] -> List n a -> Bool prop_moveUp ops l = - let - l' = applyListOps op ops l - l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l' - len = length l'' - in - maybe (len == 0) (== 0) (l'' ^. listSelectedL) + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l' + len = length l'' + in maybe (len == 0) (== 0) (l'' ^. listSelectedL) -- listMoveDown always reaches end of list (or list is empty) prop_moveDown :: (Eq a) => [ListOp a] -> List n a -> Bool prop_moveDown ops l = - let - l' = applyListOps op ops l - l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l' - len = length l'' - in - maybe (len == 0) (== len - 1) (l'' ^. listSelectedL) + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l' + len = length l'' + in maybe (len == 0) (== len - 1) (l'' ^. listSelectedL) -- move ops never change the list prop_moveOpsNeverChangeList :: (Eq a) => [ListMoveOp a] -> List n a -> Bool prop_moveOpsNeverChangeList ops l = - let - l' = applyListOps moveOp ops l - in - l' ^. listElementsL == l ^. listElementsL + let l' = applyListOps moveOp ops l + in l' ^. listElementsL == l ^. listElementsL -- If the list is empty, empty selection is used. -- Otherwise, if the specified selected index is not in list bounds, -- zero is used instead. -prop_replaceSetIndex - :: (Eq a) - => [ListOp a] -> List n a -> [a] -> Int -> Bool +prop_replaceSetIndex :: (Eq a) + => [ListOp a] + -> List n a + -> [a] + -> Int + -> Bool prop_replaceSetIndex ops l xs i = - let - v = V.fromList xs - l' = applyListOps op ops l - l'' = listReplace v (Just i) l' - i' = clamp 0 (length v - 1) i - inBounds = i == i' - in - l'' ^. listSelectedL == case (null v, inBounds) of - (True, _) -> Nothing - (False, True) -> Just i - (False, False) -> Just 0 + let v = V.fromList xs + l' = applyListOps op ops l + l'' = listReplace v (Just i) l' + i' = clamp 0 (length v - 1) i + inBounds = i == i' + in l'' ^. listSelectedL == case (null v, inBounds) of + (True, _) -> Nothing + (False, True) -> Just i + (False, False) -> Just 0 -- Replacing with no index always clears the index prop_replaceNoIndex :: (Eq a) => [ListOp a] -> List n a -> [a] -> Bool prop_replaceNoIndex ops l xs = - let - v = V.fromList xs - l' = applyListOps op ops l - in - isNothing (listReplace v Nothing l' ^. listSelectedL) + let v = V.fromList xs + l' = applyListOps op ops l + in isNothing (listReplace v Nothing l' ^. listSelectedL) -- | Move the list selected index. If the index is `Just x`, adjust by the -- specified amount; if it is `Nothing` (i.e. there is no selection) and the @@ -287,26 +265,19 @@ prop_replaceNoIndex ops l xs = -- `Just (length - 1)` (last element). Subject to validation. prop_moveByWhenNoSelection :: List n a -> Int -> Property prop_moveByWhenNoSelection l amt = - let - l' = l & listSelectedL .~ Nothing - len = length l - expected = if amt > 0 then 0 else len - 1 - in - len > 0 ==> listMoveBy amt l' ^. listSelectedL == Just expected - + let l' = l & listSelectedL .~ Nothing + len = length l + expected = if amt > 0 then 0 else len - 1 + in len > 0 ==> listMoveBy amt l' ^. listSelectedL == Just expected splitAtLength :: (Foldable t, Splittable t) => t a -> Int -> Bool splitAtLength l i = - let - len = length l - (h, t) = splitAt i l - in - length h + length t == len - && length h == clamp 0 len i + let len = length l + (h, t) = splitAt i l + in length h + length t == len && length h == clamp 0 len i -splitAtAppend - :: (Splittable t, Semigroup (t a), Eq (t a)) - => t a -> Int -> Bool +splitAtAppend :: (Splittable t, Semigroup (t a), Eq (t a)) + => t a -> Int -> Bool splitAtAppend l i = uncurry (<>) (splitAt i l) == l prop_splitAtLength_Vector :: [a] -> Int -> Bool @@ -322,16 +293,14 @@ prop_splitAtAppend_Seq :: (Eq a) => [a] -> Int -> Bool prop_splitAtAppend_Seq = splitAtAppend . Seq.fromList -reverseSingleton - :: forall t a. (Reversible t, Applicative t, Eq (t a)) - => Proxy t -> a -> Bool +reverseSingleton :: forall t a. (Reversible t, Applicative t, Eq (t a)) + => Proxy t -> a -> Bool reverseSingleton _ a = - let l = pure a :: t a - in reverse l == l + let l = pure a :: t a + in reverse l == l -reverseAppend - :: (Reversible t, Semigroup (t a), Eq (t a)) - => t a -> t a -> Bool +reverseAppend :: (Reversible t, Semigroup (t a), Eq (t a)) + => t a -> t a -> Bool reverseAppend l1 l2 = reverse (l1 <> l2) == reverse l2 <> reverse l1 @@ -340,65 +309,54 @@ prop_reverseSingleton_Vector = reverseSingleton (Proxy :: Proxy V.Vector) prop_reverseAppend_Vector :: (Eq a) => [a] -> [a] -> Bool prop_reverseAppend_Vector l1 l2 = - reverseAppend (V.fromList l1) (V.fromList l2) + reverseAppend (V.fromList l1) (V.fromList l2) prop_reverseSingleton_Seq :: (Eq a) => a -> Bool prop_reverseSingleton_Seq = reverseSingleton (Proxy :: Proxy Seq.Seq) prop_reverseAppend_Seq :: (Eq a) => [a] -> [a] -> Bool prop_reverseAppend_Seq l1 l2 = - reverseAppend (Seq.fromList l1) (Seq.fromList l2) - - + reverseAppend (Seq.fromList l1) (Seq.fromList l2) -- Laziness tests. Here we create a custom container type -- that we use to ensure certain operations do not cause the -- whole container to be evaluated. -- newtype L a = L [a] - deriving (Functor, Foldable, Traversable, Semigroup) + deriving (Functor, Foldable, Traversable, Semigroup) instance Splittable L where - splitAt i (L xs) = over both L (Data.List.splitAt i xs) + splitAt i (L xs) = over both L (Data.List.splitAt i xs) -- moveBy positive amount does not evaluate 'length' prop_moveByPosLazy :: Bool prop_moveByPosLazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 - l' = listMoveBy 1 l - in - l' ^. listSelectedL == Just 1 + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 + l' = listMoveBy 1 l + in l' ^. listSelectedL == Just 1 -- listFindBy is lazy prop_findByLazy :: Bool prop_findByLazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 & listSelectedL .~ Nothing - l' = listFindBy even l - l'' = listFindBy even l' - in - l' ^. listSelectedL == Just 1 - && l'' ^. listSelectedL == Just 3 + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Nothing + l' = listFindBy even l + l'' = listFindBy even l' + in l' ^. listSelectedL == Just 1 && + l'' ^. listSelectedL == Just 3 prop_listSelectedElement_lazy :: Bool prop_listSelectedElement_lazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 & listSelectedL .~ Just 3 - in - listSelectedElement l == Just (3, 4) + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Just 3 + in listSelectedElement l == Just (3, 4) prop_listSelectedElementL_lazy :: Bool prop_listSelectedElementL_lazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 & listSelectedL .~ Just 3 - in - over listSelectedElementL (*2) l ^? listSelectedElementL == Just 8 - + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Just 3 + in over listSelectedElementL (*2) l ^? listSelectedElementL == Just 8 return [] From 0385fa8e07e3fdfc1d0b88b4b8d8f892f58d57cf Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 28 Jul 2022 13:10:15 -0700 Subject: [PATCH 32/37] tests/List.hs: make Semigroup import conditional --- tests/List.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/List.hs b/tests/List.hs index 28558eb..4a198bc 100644 --- a/tests/List.hs +++ b/tests/List.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -17,7 +18,9 @@ import qualified Data.List import Data.Maybe (isNothing) import Data.Monoid (Endo(..)) import Data.Proxy +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) +#endif import qualified Data.Sequence as Seq import qualified Data.Vector as V From 6dc25d79049556990b8b79918c1ca0861d91521f Mon Sep 17 00:00:00 2001 From: Fraser Tweedale Date: Thu, 28 Jul 2022 23:34:32 +1000 Subject: [PATCH 33/37] refactor some list functions Use listSelectedElementL to simplify the implementation and improve asymptotics of some list functions. Introduces some additional constraints on these functions, so this change requires a major version bump. - `listModify`: Improved asymptotics for `Seq`. Introduces `Splittable` and `Semigroup` constraint. - `listSelectedElement`: Simpler definition. Asymptotics unchanged. Introduces `Semigroup` constraint and strengthens `Foldable` constraint to `Traversable`. --- src/Brick/Widgets/List.hs | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs index 45afec0..ed32bf2 100644 --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -82,7 +82,7 @@ import Control.Applicative ((<|>)) import Data.Foldable (find, toList) import Control.Monad.Trans.State (evalState, get, put) -import Lens.Micro (Traversal', (^.), (^?), (&), (.~), (%~), _2, _head, set) +import Lens.Micro (Traversal', (^.), (^?), (&), (.~), (%~), _2, set) import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (fromMaybe) @@ -635,13 +635,11 @@ listSelectedElementL f l = -- listSelectedElement for 'List': O(1) -- listSelectedElement for 'Seq.Seq': O(log(min(i, n - i))) -- @ -listSelectedElement :: (Splittable t, Foldable t) +listSelectedElement :: (Splittable t, Traversable t, Semigroup (t e)) => GenericList n t e -> Maybe (Int, e) -listSelectedElement l = do - sel <- l^.listSelectedL - let (_, xs) = splitAt sel (l ^. listElementsL) - (sel,) <$> toList xs ^? _head +listSelectedElement l = + (,) <$> l^.listSelectedL <*> l^?listSelectedElementL -- | Remove all elements from the list and clear the selection. -- @@ -670,11 +668,16 @@ listReverse l = -- -- Complexity: same as 'traverse' for the container type (typically -- /O(n)/). -listModify :: (Traversable t) +-- +-- Complexity: same as 'listSelectedElementL' for the list's container type. +-- +-- @ +-- listModify for 'List': O(n) +-- listModify for 'Seq.Seq': O(log(min(i, n - i))) +-- @ +-- +listModify :: (Traversable t, Splittable t, Semigroup (t e)) => (e -> e) -> GenericList n t e -> GenericList n t e -listModify f l = - case l ^. listSelectedL of - Nothing -> l - Just j -> l & listElementsL %~ imap (\i e -> if i == j then f e else e) +listModify f = listSelectedElementL %~ f From e8ed13ee4258fafa62feabef82bdc6b0b0eeb0f8 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 28 Jul 2022 18:29:25 -0700 Subject: [PATCH 34/37] Forms: suppress unused lens warning --- src/Brick/Forms.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index 16c3d43..4e2cb29 100644 --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -4,6 +4,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- | 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 From 02c9acfe64cb7155d88db57de5199707bc7ff93d Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 28 Jul 2022 18:31:18 -0700 Subject: [PATCH 35/37] Forms: style nit --- src/Brick/Forms.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index 4e2cb29..f5315c4 100644 --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -765,10 +765,10 @@ handleFormEvent (VtyEvent (EvKey KBackTab [])) = formFocusL %= focusPrev handleFormEvent e@(MouseDown n _ _ _) = do formFocusL %= focusSetCurrent n - handleFormFieldEvent n e + handleFormFieldEvent e n handleFormEvent e@(MouseUp n _ _) = do formFocusL %= focusSetCurrent n - handleFormFieldEvent n e + handleFormFieldEvent e n handleFormEvent e@(VtyEvent (EvKey KUp [])) = withFocusAndGrouping e $ \n grp -> formFocusL %= focusSetCurrent (entryBefore grp n) @@ -824,12 +824,11 @@ withFocus act = do Just n -> act n forwardToCurrent :: (Eq n) => BrickEvent n e -> EventM n (Form s e n) () -forwardToCurrent e = - withFocus $ \n -> do - handleFormFieldEvent n e +forwardToCurrent = + withFocus . handleFormFieldEvent -handleFormFieldEvent :: (Eq n) => n -> BrickEvent n e -> EventM n (Form s e n) () -handleFormFieldEvent n ev = do +handleFormFieldEvent :: (Eq n) => BrickEvent n e -> n -> EventM n (Form s e n) () +handleFormFieldEvent ev n = do let findFieldState _ [] = return () findFieldState prev (e:es) = case e of From 23fc05e1803c6d5b91fc7bb838015aa0f2d03f03 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 28 Jul 2022 18:31:52 -0700 Subject: [PATCH 36/37] Whitespace --- src/Brick/Forms.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index f5315c4..cb376e2 100644 --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -781,7 +781,8 @@ handleFormEvent e@(VtyEvent (EvKey KLeft [])) = handleFormEvent e@(VtyEvent (EvKey KRight [])) = withFocusAndGrouping e $ \n grp -> formFocusL %= focusSetCurrent (entryAfter grp n) -handleFormEvent e = forwardToCurrent e +handleFormEvent e = + forwardToCurrent e getFocusGrouping :: (Eq n) => Form s e n -> n -> Maybe [n] getFocusGrouping f n = findGroup (formFieldStates f) From c9963d042916558912b862652a3273965c6b9809 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Thu, 28 Jul 2022 18:43:26 -0700 Subject: [PATCH 37/37] renderRadio: remove unnecessary hBox --- src/Brick/Forms.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs index cb376e2..313b43d 100644 --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -482,10 +482,11 @@ renderRadio lb check rb val name label foc cur = csr = if foc then putCursor name (Location (1,0)) else id in clickable name $ addAttr $ csr $ - hBox [ txt $ T.singleton lb - , txt $ if isSet then T.singleton check else " " - , txt $ T.singleton rb <> " " <> label - ] + txt $ T.concat $ + [ T.singleton lb + , if isSet then T.singleton check else " " + , T.singleton rb <> " " <> label + ] -- | A form field for using an editor to edit the text representation of -- a value. The other editing fields in this module are special cases of