jtdaugherty/brick
1
1
Fork 0
mirror of https://github.com/jtdaugherty/brick.git synced 2024-11-26 09:06:56 +03:00
Code Issues Projects Releases Wiki Activity

Initial refactor of EventM to be a state monad (also migrates to mtl)

Browse Source
This commit is contained in:
Jonathan Daugherty 2022-07-15 17:04:18 -07:00
parent b23c40d82a
commit 5db48f2820
10 changed files with 220 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
brick.cabal
View File

@ -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,

107
src/Brick/Main.hs
View File

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

38
src/Brick/Types.hs
View File

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

29
src/Brick/Types/Internal.hs
View File

@ -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

6
src/Brick/Widgets/Core.hs
View File

@ -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

7
src/Brick/Widgets/Dialog.hs
View File

@ -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

12
src/Brick/Widgets/Edit.hs
View File

@ -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

162
src/Brick/Widgets/FileBrowser.hs
View File

@ -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

5
src/Brick/Widgets/Internal.hs
View File

@ -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

62
src/Brick/Widgets/List.hs
View File

@ -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.
--