jtdaugherty/brick
1
1
Fork 0
mirror of https://github.com/jtdaugherty/brick.git synced 2024-11-29 21:46:11 +03:00
Code Issues Projects Releases Wiki Activity

Merge refactor/event-state-monad

Browse Source
This commit is contained in:
Jonathan Daugherty 2022-08-02 18:49:36 -07:00
commit a8e1bf5909
35 changed files with 1022 additions and 835 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
FAQ.md
View File

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

43
brick.cabal
View File

@ -114,12 +114,12 @@ library
other-modules:
Brick.Types.Common
Brick.Types.TH
Brick.Types.EventM
Brick.Types.Internal
Brick.Widgets.Internal
build-depends: base >= 4.9.0.0 && < 4.17.0.0,
vty >= 5.36,
transformers,
bimap >= 0.5 && < 0.6,
data-clist >= 0.1,
directory >= 1.2.5.0,
@ -130,6 +130,7 @@ library
microlens >= 0.3.0.0,
microlens-th,
microlens-mtl,
mtl,
config-ini,
vector,
contravariant,
@ -167,7 +168,9 @@ executable brick-tail-demo
brick,
text,
vty,
random
random,
microlens-th,
microlens-mtl
executable brick-readme-demo
if !flag(demos)
@ -192,7 +195,8 @@ executable brick-file-browser-demo
build-depends: base,
vty,
brick,
text
text,
mtl
executable brick-form-demo
if !flag(demos)
@ -235,7 +239,8 @@ executable brick-cache-demo
vty,
text,
microlens >= 0.3.0.0,
microlens-th
microlens-th,
mtl
executable brick-visibility-demo
if !flag(demos)
@ -249,7 +254,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)
@ -263,7 +269,9 @@ executable brick-viewport-scrollbars-demo
brick,
vty,
text,
microlens
microlens,
microlens-mtl,
microlens-th
executable brick-viewport-scroll-demo
if !flag(demos)
@ -305,7 +313,9 @@ executable brick-mouse-demo
text,
microlens >= 0.3.0.0,
microlens-th,
text-zipper
microlens-mtl,
text-zipper,
mtl
executable brick-layer-demo
if !flag(demos)
@ -319,7 +329,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)
@ -372,6 +383,7 @@ executable brick-theme-demo
brick,
vty,
text,
mtl,
microlens
executable brick-attr-demo
@ -399,6 +411,8 @@ executable brick-list-demo
vty,
text,
microlens >= 0.3.0.0,
microlens-mtl,
mtl,
vector
executable brick-list-vi-demo
@ -413,6 +427,8 @@ executable brick-list-vi-demo
vty,
text,
microlens >= 0.3.0.0,
microlens-mtl,
mtl,
vector
executable brick-custom-event-demo
@ -427,7 +443,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)
@ -467,8 +484,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)
@ -510,7 +529,9 @@ executable brick-progressbar-demo
brick,
vty,
text,
microlens
microlens,
microlens-mtl,
microlens-th
test-suite brick-tests
type: exitcode-stdio-1.0

21
docs/guide.rst
View File

@ -921,12 +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 use of
the `utf8proc`_ library to determine the column width of each character
rendered.
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
@ -945,8 +949,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
@ -1924,4 +1928,3 @@ sub-widget uses for rendering its output.
.. _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/

2
programs/AttrDemo.hs
View File

@ -70,7 +70,7 @@ app :: App () e ()
app =
App { appDraw = const [ui]
, appHandleEvent = resizeOrQuit
, appStartEvent = return
, appStartEvent = return ()
, appAttrMap = const theMap
, appChooseCursor = neverShowCursor
}

18
programs/CacheDemo.hs
View File

@ -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
@ -16,7 +17,8 @@ import Brick.Types
, BrickEvent(..)
)
import Brick.Widgets.Core
( vBox
( Padding(..)
, vBox
, padTopBottom
, withDefAttr
, cached
@ -50,18 +52,18 @@ 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"
, 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 +71,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

4
programs/CroppingDemo.hs
View File

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

22
programs/CustomEventDemo.hs
View File

@ -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 []
}

14
programs/DialogDemo.hs
View File

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

28
programs/EditDemo.hs
View File

@ -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 -> zoom edit1 $ E.handleEditorEvent ev
Just Edit2 -> zoom 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
}

26
programs/FileBrowserDemo.hs
View File

@ -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
@ -27,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
@ -44,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 $
@ -55,22 +57,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 +99,7 @@ theApp =
M.App { M.appDraw = drawUI
, M.appChooseCursor = M.showFirstCursor
, M.appHandleEvent = appEvent
, M.appStartEvent = return
, M.appStartEvent = return ()
, M.appAttrMap = const theMap
}

16
programs/FormDemo.hs
View File

@ -112,22 +112,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
}

43
programs/LayerDemo.hs
View File

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

32
programs/ListDemo.hs
View File

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

32
programs/ListViDemo.hs
View File

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

46
programs/MouseDemo.hs
View File

@ -3,9 +3,11 @@
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Lens.Micro ((^.), (&), (.~))
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
@ -43,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))
@ -83,18 +85,22 @@ 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)
zoom 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 =
zoom edit $ E.handleEditorEvent ev
aMap :: AttrMap
aMap = attrMap V.defAttr
@ -108,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
@ -116,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."

4
programs/PaddingDemo.hs
View File

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

31
programs/ProgressBarDemo.hs
View File

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

19
programs/SuspendAndResumeDemo.hs
View File

@ -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 []
}

65
programs/TailDemo.hs
View File

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

16
programs/ThemeDemo.hs
View File

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

24
programs/ViewportScrollDemo.hs
View File

@ -59,22 +59,22 @@ vp2Scroll = M.viewportScroll VP2
vp3Scroll :: M.ViewportScroll Name
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

34
programs/ViewportScrollbarsDemo.hs
View File

@ -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 ((<>))
@ -26,7 +29,8 @@ import Brick.AttrMap
, attrMap
)
import Brick.Widgets.Core
( hLimit
( Padding(..)
, hLimit
, vLimit
, padRight
, hBox
@ -57,7 +61,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,9 +71,9 @@ 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) $
pair = hBox [ padRight (Pad 5) $
B.border $
withClickableHScrollBars SBClick $
withHScrollBars OnBottom $
@ -92,13 +98,13 @@ vp1Scroll = M.viewportScroll VP1
vp2Scroll :: M.ViewportScroll Name
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 +125,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 +138,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

25
programs/VisibilityDemo.hs
View File

@ -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
@ -102,17 +103,17 @@ vp2Scroll = M.viewportScroll VP2
vp3Scroll :: M.ViewportScroll Name
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

154
src/Brick/Forms.hs
View File

@ -3,6 +3,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# 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
@ -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,10 +141,8 @@ 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
-- ^ An event handler for this field. This receives the
-- event and the field state and returns a new field
-- state.
, formFieldHandleEvent :: BrickEvent n e -> EventM n b ()
-- ^ An event handler for this field.
}
-- | A form field state accompanied by the fields that manipulate that
@ -216,6 +217,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 +331,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 +388,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 +450,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) =
@ -479,9 +482,10 @@ 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
@ -729,8 +733,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.
@ -755,44 +759,31 @@ 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 e n
handleFormEvent e@(MouseUp n _ _) = do
formFocusL %= focusSetCurrent n
handleFormFieldEvent e n
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,31 @@ 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 =
withFocus . handleFormFieldEvent
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
FormFieldState st stLens upd fields helper concatAll -> do
@ -833,7 +839,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, ()) <- nestEventM st (handleFunc ev)
-- If the new state validates, go ahead and update
-- the form state with it.
case validate nextSt of
@ -844,10 +850,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

246
src/Brick/Main.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Brick.Main
( App(..)
, defaultMain
@ -9,10 +10,10 @@ module Brick.Main
, simpleApp
-- * Event handler functions
, continue
, continueWithoutRedraw
, halt
, suspendAndResume
, suspendAndResume'
, makeVisible
, lookupViewport
, lookupExtent
@ -53,10 +54,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.Strict
import Control.Monad.Reader
import Control.Concurrent (forkIO, killThread)
import qualified Data.Foldable as F
import Data.List (find)
@ -81,7 +80,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
@ -110,13 +109,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 +158,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,45 +168,39 @@ 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
data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a)
| InternalHalt a
resizeOrQuit :: BrickEvent n e -> EventM n s ()
resizeOrQuit (VtyEvent (EvResize _ _)) = return ()
resizeOrQuit _ = halt
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
(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 s -> do
killThread pid
return $ InternalHalt s
Continue s -> runInner newRS newExtents True s
ContinueWithoutRedraw s ->
runInner newRS newExtents False s
runInner initialRS mempty True initialSt
Halt ->
return (nextSt, newCtx)
Continue ->
runInner newCtx newRS newExtents True nextSt
ContinueWithoutRedraw ->
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
@ -267,22 +260,19 @@ 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
let emptyES = ES { esScrollRequests = []
, cacheInvalidateRequests = mempty
, requestedVisibleNames = mempty
, 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
(st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) 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
@ -291,27 +281,57 @@ customMainWithVty initialVty buildVty mUserChan app initialAppState = do
, requestedVisibleNames_ = requestedVisibleNames eState
, reportedExtents = mempty
}
brickChan <- newBChan 20
run initialVty initialRS st 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 appState
`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 (Next 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
@ -322,7 +342,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
@ -374,18 +394,20 @@ runVty vty readEvent app appState rs prevExtents draw = do
_ -> return (e, firstRS, exts)
_ -> return (e, firstRS, exts)
let emptyES = ES [] mempty mempty
eventRO = EventRO (viewportMap nextRS) vty nextExts nextRS
let emptyES = ES [] mempty mempty Continue vtyCtx
eventRO = EventRO (viewportMap nextRS) nextExts nextRS
(next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e'))
eventRO) emptyES
return ( next
(((), newAppState), eState) <- runStateT (runStateT (runReaderT (runEventM (appHandleEvent app e'))
eventRO) appState) emptyES
return ( newAppState
, nextAction eState
, nextRS { rsScrollRequests = esScrollRequests eState
, renderCache = applyInvalidations (cacheInvalidateRequests eState) $
renderCache nextRS
, requestedVisibleNames_ = requestedVisibleNames eState
}
, nextExts
, vtyContext eState
)
applyInvalidations :: (Ord n) => S.Set (CacheInvalidateRequest n) -> M.Map n v -> M.Map n v
@ -410,7 +432,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 +444,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 +454,32 @@ 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 $ asks eventVtyHandle
getVtyHandle :: EventM n s Vty
getVtyHandle = vtyContextHandle <$> getVtyContext
setVtyContext :: VtyContext -> EventM n s ()
setVtyContext 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 ()
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 ()
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 (RenderState n)
getRenderState :: EventM n s (RenderState n)
getRenderState = EventM $ asks oldState
resetRenderState :: RenderState n -> RenderState n
@ -461,9 +487,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
@ -478,7 +504,7 @@ renderApp vty app appState rs = do
(cloc^.locationRowL)
}
update vty picWithCursor
update (vtyContextHandle vtyCtx) picWithCursor
return (newRS, exts)
@ -509,38 +535,38 @@ data ViewportScroll n =
ViewportScroll { viewportName :: n
-- ^ The name of the viewport to be controlled by
-- this scrolling handle.
, hScrollPage :: Direction -> EventM n ()
, hScrollPage :: forall s. Direction -> EventM n s ()
-- ^ Scroll the viewport horizontally by one page in
-- the specified direction.
, hScrollBy :: Int -> EventM n ()
, 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 ()
, hScrollToBeginning :: forall s. EventM n s ()
-- ^ Scroll horizontally to the beginning of the
-- viewport.
, hScrollToEnd :: EventM n ()
, hScrollToEnd :: forall s. EventM n s ()
-- ^ Scroll horizontally to the end of the viewport.
, vScrollPage :: Direction -> EventM n ()
, vScrollPage :: forall s. Direction -> EventM n s ()
-- ^ Scroll the viewport vertically by one page in
-- the specified direction.
, vScrollBy :: Int -> EventM n ()
, 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 ()
, vScrollToBeginning :: forall s. EventM n s ()
-- ^ Scroll vertically to the beginning of the viewport.
, vScrollToEnd :: EventM n ()
, vScrollToEnd :: forall s. EventM n s ()
-- ^ Scroll vertically to the end of the viewport.
, setTop :: Int -> EventM n ()
, setTop :: forall s. Int -> EventM n s ()
-- ^ Set the top row offset of the viewport.
, setLeft :: Int -> EventM n ()
, setLeft :: forall s. 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 })
lift $ lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s })
-- | Build a viewport scroller for the viewport with the specified name.
viewportScroll :: n -> ViewportScroll n
@ -558,11 +584,6 @@ viewportScroll n =
, setLeft = \i -> addScrollRequest (n, SetLeft i)
}
-- | Continue running the event loop with the specified application
-- state.
continue :: s -> EventM n (Next s)
continue = return . 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
@ -571,30 +592,51 @@ 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 $ 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 $ 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
-- 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 (Next s)
suspendAndResume = return . SuspendAndResume
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
-- 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 })
lift $ lift $ modify (\s -> s { requestedVisibleNames = S.insert n $ requestedVisibleNames s })

94
src/Brick/Types.hs
View File

@ -1,7 +1,6 @@
-- | Basic types used by this library.
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Brick.Types
( -- * The Widget type
@ -27,11 +26,11 @@ module Brick.Types
, ScrollbarRenderer(..)
, ClickableScrollbarElement(..)
-- * Event-handling types
, EventM(..)
, Next
-- * Event-handling types and functions
, EventM
, BrickEvent(..)
, handleEventLensed
, nestEventM
, nestEventM'
-- * Rendering infrastructure
, RenderM
@ -85,63 +84,72 @@ module Brick.Types
-- * Miscellaneous
, Size(..)
, Padding(..)
, Direction(..)
-- * Renderer internals (for benchmarking)
, RenderState
-- * Re-exports for convenience
, get
, gets
, put
, modify
, zoom
)
where
import Lens.Micro (_1, _2, to, (^.), (&), (.~), Lens')
import Lens.Micro (_1, _2, to, (^.))
import Lens.Micro.Type (Getting)
import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
import Lens.Micro.Mtl (zoom)
#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.Strict
import Control.Monad.Reader
import Graphics.Vty (Attr)
import Control.Monad.IO.Class
import Brick.Types.TH
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 resulting modified state.
nestEventM' :: a
-- ^ The initial state to use in the nested action.
-> EventM n a b
-- ^ The action to run.
-> EventM n s a
nestEventM' s act = fst <$> nestEventM s act
-- | 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 :: a
-- ^ The state value.
-> Lens' a b
-- ^ The lens to use to extract and store the target
-- of the event.
-> (e -> b -> EventM n b)
-- ^ 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
-- | 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
-- | 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 initial state to use in the nested action.
-> EventM n a b
-- ^ The action to run.
-> EventM n s (a, b)
nestEventM s' act = do
ro <- EventM ask
es <- EventM $ lift $ lift get
vtyCtx <- getVtyContext
let stInner = ES { nextAction = Continue
, esScrollRequests = esScrollRequests es
, cacheInvalidateRequests = cacheInvalidateRequests es
, requestedVisibleNames = requestedVisibleNames es
, vtyContext = vtyCtx
}
deriving ( Functor, Applicative, Monad, MonadIO
, MonadThrow, MonadCatch, MonadMask, MonadFail
)
((actResult, newSt), stInnerFinal) <- liftIO $ runStateT (runStateT (runReaderT (runEventM act) ro) s') stInner
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

38
src/Brick/Types/EventM.hs Normal file
View File

@ -0,0 +1,38 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Brick.Types.EventM
( EventM(..)
, getVtyContext
)
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 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 get
put = EventM . lift . put
getVtyContext :: EventM n s 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)

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

@ -45,8 +45,9 @@ module Brick.Types.Internal
, Size(..)
, EventState(..)
, VtyContext(..)
, EventRO(..)
, Next(..)
, NextAction(..)
, Result(..)
, Extent(..)
, Edges(..)
@ -82,9 +83,9 @@ module Brick.Types.Internal
)
where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Lazy
import Control.Concurrent (ThreadId)
import Control.Monad.Reader
import Control.Monad.State.Strict
import Lens.Micro (_1, _2, Lens')
import Lens.Micro.Mtl (use)
import Lens.Micro.TH (makeLenses)
@ -214,7 +215,8 @@ data Viewport =
-- | The type of viewports that indicates the direction(s) in which a
-- viewport is scrollable.
data ViewportType = Vertical
data ViewportType =
Vertical
-- ^ Viewports of this type are scrollable only vertically.
| Horizontal
-- ^ Viewports of this type are scrollable only horizontally.
@ -227,24 +229,33 @@ 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 =
ES { esScrollRequests :: ![(n, ScrollRequest)]
, cacheInvalidateRequests :: !(S.Set (CacheInvalidateRequest n))
, requestedVisibleNames :: !(S.Set n)
, 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
, extentSize :: (Int, Int)
data Extent n = Extent { extentName :: !n
, extentUpperLeft :: !Location
, extentSize :: !(Int, Int)
}
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 =
Continue
| ContinueWithoutRedraw
| Halt
-- | Scrolling direction.
data Direction = Up
@ -310,15 +321,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
@ -331,7 +342,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.
}
@ -362,7 +373,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
}

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

@ -22,6 +22,7 @@ module Brick.Widgets.Core
, hyperlink
-- * Padding
, Padding(..)
, padLeft
, padRight
, padTop
@ -121,10 +122,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.Strict
import Control.Monad.Reader
import qualified Data.Foldable as F
import qualified Data.Text as T
import qualified Data.DList as DL
@ -377,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.

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

@ -72,9 +72,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

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

@ -119,11 +119,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 +156,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

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

@ -155,6 +155,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
@ -356,8 +357,8 @@ setWorkingDirectory path b = do
Left (_::E.IOException) -> entries
Right parent -> parent : entries
let b' = setEntries allEntries b
return $ b' & fileBrowserWorkingDirectoryL .~ path
return $ (setEntries allEntries b)
& fileBrowserWorkingDirectoryL .~ path
& fileBrowserExceptionL .~ exc
& fileBrowserSelectedFilesL .~ mempty
@ -593,126 +594,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 =
zoom 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 =
zoom 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 =
zoom 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 =
zoom 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
modify $ updateFileBrowserSearch (const Nothing)
Vty.EvKey Vty.KEsc [] ->
return $ updateFileBrowserSearch (const Nothing) b
modify $ updateFileBrowserSearch (const Nothing)
Vty.EvKey Vty.KBS [] ->
return $ updateFileBrowserSearch (fmap safeInit) b
Vty.EvKey Vty.KEnter [] ->
updateFileBrowserSearch (const Nothing) <$>
maybeSelectCurrentEntry b
modify $ updateFileBrowserSearch (fmap safeInit)
Vty.EvKey Vty.KEnter [] -> do
maybeSelectCurrentEntry
modify $ updateFileBrowserSearch (const Nothing)
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
zoom fileBrowserEntriesL $ handleListEvent e
-- | If the browser's current entry is selectable according to
-- @fileBrowserSelectable@, add it to the selection set and return.
@ -720,30 +715,32 @@ 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
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 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.Strict
import Control.Monad.Reader
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import qualified Data.Set as S

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

@ -37,6 +37,7 @@ module Brick.Widgets.List
, listSelectedL
, listNameL
, listItemHeightL
, listSelectedElementL
-- * Accessors
, listElements
@ -79,9 +80,9 @@ 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)
import Lens.Micro ((^.), (^?), (&), (.~), (%~), _2, _head, set)
import Lens.Micro (Traversal', (^.), (^?), (&), (.~), (%~), _2, set)
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Maybe (fromMaybe)
@ -193,17 +194,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 +219,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 +473,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 +485,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.
--
@ -602,6 +599,28 @@ 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 the list's 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 (\m -> left <> m <> right) <$> (traverse f middle)
-- | Return a list's selected element, if any.
--
-- Only evaluates as much of the container as needed.
@ -612,13 +631,11 @@ listFindBy test 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.
--
@ -647,11 +664,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

191
tests/List.hs
View File

@ -1,14 +1,14 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
module List
(
main
) where
( main
)
where
import Prelude hiding (reverse, splitAt)
@ -18,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
@ -31,10 +33,9 @@ import Brick.Widgets.List
instance (Arbitrary n, Arbitrary a) => Arbitrary (List n a) where
arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1
-- List move operations that never modify the underlying list
data ListMoveOp a
= MoveUp
data ListMoveOp a =
MoveUp
| MoveDown
| MoveBy Int
| MoveTo Int
@ -43,8 +44,8 @@ data ListMoveOp a
deriving (Show)
instance Arbitrary a => Arbitrary (ListMoveOp a) where
arbitrary = oneof
[ pure MoveUp
arbitrary =
oneof [ pure MoveUp
, pure MoveDown
, MoveBy <$> arbitrary
, MoveTo <$> arbitrary
@ -54,8 +55,8 @@ instance Arbitrary a => Arbitrary (ListMoveOp a) where
-- 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
data ListOp a =
Insert Int a
| Remove Int
| Replace Int [a]
| Clear
@ -64,8 +65,8 @@ data ListOp a
deriving (Show)
instance Arbitrary a => Arbitrary (ListOp a) where
arbitrary = frequency
[ (1, Insert <$> arbitrary <*> arbitrary)
arbitrary =
frequency [ (1, Insert <$> arbitrary <*> arbitrary)
, (1, Remove <$> arbitrary)
, (1, Replace <$> arbitrary <*> arbitrary)
, (1, pure Clear)
@ -93,12 +94,13 @@ 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 =
@ -106,27 +108,28 @@ prop_initialSelection xs =
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
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
let l' = applyListOps op ops l
l'' = listReverse l'
in
fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'')
in fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'')
-- reversing maintains size of list
prop_reverseMaintainsSizeOfList :: List n a -> Bool
@ -137,19 +140,15 @@ prop_reverseMaintainsSizeOfList l =
-- (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
let l' = listInsert i a l
i' = clamp 0 (length l) i
in
listSelectedElement (listMoveTo i' l') == Just (i', a)
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 +159,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)
let l' = listInsert i a (applyListOps op ops l)
sel = listSelectedElement (listMoveToElement a l')
in
fmap snd sel == Just a
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 +169,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
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)
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
let i' = clamp 0 (length l) i
l' = listInsert i' a l -- pre-clamped
l'' = listRemove i' l'
in
l'' ^. listElementsL == l ^. listElementsL
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
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))
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)
let sel = listSelectedElement (listMoveTo i l)
l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l
in
l' ^. listElementsL == l ^. listElementsL
in l' ^. listElementsL == l ^. listElementsL
-- Apply @f@ until @test a (f a) == True@, then return @a@.
converge :: (a -> a -> Bool) -> (a -> a) -> a -> a
@ -228,46 +216,41 @@ converging test 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
let l' = applyListOps op ops l
l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l'
len = length l''
in
maybe (len == 0) (== 0) (l'' ^. listSelectedL)
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
let l' = applyListOps op ops l
l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l'
len = length l''
in
maybe (len == 0) (== len - 1) (l'' ^. listSelectedL)
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
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
in l'' ^. listSelectedL == case (null v, inBounds) of
(True, _) -> Nothing
(False, True) -> Just i
(False, False) -> Just 0
@ -275,11 +258,9 @@ prop_replaceSetIndex ops l xs i =
-- 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
let v = V.fromList xs
l' = applyListOps op ops l
in
isNothing (listReplace v Nothing l' ^. listSelectedL)
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,25 +268,18 @@ 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
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
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
let len = length l
(h, t) = splitAt i l
in
length h + length t == len
&& length h == clamp 0 len i
in length h + length t == len && length h == clamp 0 len i
splitAtAppend
:: (Splittable t, Semigroup (t a), Eq (t a))
splitAtAppend :: (Splittable t, Semigroup (t a), Eq (t a))
=> t a -> Int -> Bool
splitAtAppend l i = uncurry (<>) (splitAt i l) == l
@ -322,15 +296,13 @@ 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))
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
reverseAppend
:: (Reversible t, Semigroup (t a), Eq (t a))
reverseAppend :: (Reversible t, Semigroup (t a), Eq (t a))
=> t a -> t a -> Bool
reverseAppend l1 l2 =
reverse (l1 <> l2) == reverse l2 <> reverse l1
@ -349,14 +321,12 @@ prop_reverseAppend_Seq :: (Eq a) => [a] -> [a] -> Bool
prop_reverseAppend_Seq l1 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)
deriving (Functor, Foldable, Traversable, Semigroup)
instance Splittable L where
splitAt i (L xs) = over both L (Data.List.splitAt i xs)
@ -364,25 +334,32 @@ instance Splittable L where
-- moveBy positive amount does not evaluate 'length'
prop_moveByPosLazy :: Bool
prop_moveByPosLazy =
let
v = L (1:2:3:4:undefined) :: L Int
let v = L (1:2:3:4:undefined) :: L Int
l = list () v 1
l' = listMoveBy 1 l
in
l' ^. listSelectedL == Just 1
in l' ^. listSelectedL == Just 1
-- listFindBy is lazy
prop_findByLazy :: Bool
prop_findByLazy =
let
v = L (1:2:3:4:undefined) :: L Int
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
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)
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 []