diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,85 @@ Brick changelog --------------- +1.0 +--- + +Version 1.0 of `brick` comes with some improvements that will require +you to update your programs. This section details the list of API +changes in 1.0 that are likely to introduce breakage and how to deal +with each one. You can also consult the demonstration +programs to see orking examples of the new API. For those +interested in a bit of discussion on the changes, see [this +ticket](https://github.com/jtdaugherty/brick/issues/379). + +* The event-handling monad `EventM` was improved and changed in some + substantial ways, all aimed at making `EventM` code cleaner, more + composable, and more amenable to lens updates to the application + state. + * The type has changed from `EventM n a` to `EventM n s a` and is now + an `mtl`-compatible state monad over `s`. Some consequences and + related changes are: + * Event handlers no longer take and return an explicit state value; + an event handler that formerly had the type `handler :: s -> + BrickEvent n e -> EventM n (Next s)` now has type `handler :: + BrickEvent n e -> EventM n s ()`. This also affected all of + Brick's built-in event handler functions for `List`, `Editor`, + etc. + * The `appHandleEvent` and `appStartEvent` fields of `App` changed + types to reflect the new structure of `EventM`. `appStartEvent` + will just be `return ()` rather than `return` for most + applications. + * `EventM` can be used with the `MonadState` API from `mtl` as well + as with the very nice lens combinators in `microlens-mtl`. + * The `Next` type was removed. + * State-specific event handlers like `handleListEvent` and + `handleEditorEvent` are now statically typed to be scoped to + just the states they manage, so `zoom` from `microlens-mtl` must + be used to invoke them. `Brick.Types` re-exports `zoom` for + convenience. `handleEventLensed` was removed from the API in lieu + of the new `zoom` behavior. Code that previously handled events + with `handleEventLensed s someLens someHandler e` is now just + written `zoom someLens $ someHandler e`. + * If an `EventM` block needs to operate on some state `s` that is + not accessible via a lens into the application state, the `EventM` + block can be set up with `Brick.Types.nestEventM`. + * Since `Next` was removed, control flow is now as follows: + * Without any explicit specification, an `EventM` block always + continues execution of the `brick` event loop when it finishes. + `continue` was removed from the API. What was previously `continue + $ s & someLens .~ value` will become `someLens .= value`. + * `halt` is still used to indicate that the event loop should halt + after the calling handler is finished, but `halt` no longer takes + an explicit state value argument. + * `suspendAndResume` is now immediate; previously, + `suspendAndResume` indicated that the specified action should run + once the event handler finished. Now, the event handler is paused + while the specified action is run. This allows `EventM` code to + continue to run after `suspendAndResume` is called and before + control is returned to `brick`. + * Brick now depends on `mtl` rather than `transformers`. +* The `IsString` instance for `AttrName` was removed. + * This change is motivated by the API wart that resulted from the + overloading of both `<>` and string literals (via + `OverloadedStrings`) that resulted in code such as `someAttrName + = "blah" <> "things"`. While that worked to create an `AttrName` + with two segments, it was far too easy to read as two strings + concatenated. The overloading hid what is really going on with the + segments of the attribute name. The way to write the above example + after this change is `someAttrName = attrName "blah" <> attrName + "things"`. + +Other changes in this release: + +* Brick now provides an optional API for user-defined keybindings + for applications! See the User Guide section "Customizable + Keybindings", the Haddock for `Brick.Keybindings.KeyDispatcher`, + and the new demo program `programs/CustomKeybindingDemo.hs` to get + started. +* `Brick.Widgets.List` got `listSelectedElementL`, a traversal for + accessing the currently selected element of a list. (Thanks Fraser + Tweedale) + 0.73 ---- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -119,7 +119,6 @@ Documentation for `brick` comes in a variety of forms: * [The official brick user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst) -* [Samuel Tay's brick tutorial](https://github.com/jtdaugherty/brick/blob/master/docs/samtay-tutorial.md) * Haddock (all modules) * [Demo programs](https://github.com/jtdaugherty/brick/blob/master/programs) ([Screenshots](https://github.com/jtdaugherty/brick/blob/master/docs/programs-screenshots.md)) * [FAQ](https://github.com/jtdaugherty/brick/blob/master/FAQ.md) diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,5 +1,5 @@ name: brick -version: 0.73 +version: 1.0 synopsis: A declarative terminal user interface library description: Write terminal user interfaces (TUIs) painlessly with 'brick'! You @@ -42,9 +42,9 @@ extra-doc-files: README.md, docs/guide.rst, - docs/samtay-tutorial.md, docs/snake-demo.gif, CHANGELOG.md, + programs/custom_keys.ini, docs/programs-screenshots.md, docs/programs-screenshots/brick-attr-demo.png, docs/programs-screenshots/brick-border-demo.png, @@ -88,6 +88,12 @@ Brick.AttrMap Brick.BChan Brick.BorderMap + Brick.Keybindings + Brick.Keybindings.KeyConfig + Brick.Keybindings.KeyEvents + Brick.Keybindings.KeyDispatcher + Brick.Keybindings.Parse + Brick.Keybindings.Pretty Brick.Focus Brick.Forms Brick.Main @@ -108,12 +114,13 @@ 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, dlist, @@ -123,6 +130,7 @@ microlens >= 0.3.0.0, microlens-th, microlens-mtl, + mtl, config-ini, vector, contravariant, @@ -135,6 +143,22 @@ bytestring, word-wrap >= 0.2 +executable brick-custom-keybinding-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: CustomKeybindingDemo.hs + build-depends: base, + brick, + text, + vty, + microlens, + microlens-mtl, + microlens-th + executable brick-table-demo if !flag(demos) Buildable: False @@ -160,7 +184,9 @@ brick, text, vty, - random + random, + microlens-th, + microlens-mtl executable brick-readme-demo if !flag(demos) @@ -185,7 +211,8 @@ build-depends: base, vty, brick, - text + text, + mtl executable brick-form-demo if !flag(demos) @@ -228,7 +255,8 @@ vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + mtl executable brick-visibility-demo if !flag(demos) @@ -242,7 +270,8 @@ vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-viewport-scrollbars-demo if !flag(demos) @@ -256,7 +285,9 @@ brick, vty, text, - microlens + microlens, + microlens-mtl, + microlens-th executable brick-viewport-scroll-demo if !flag(demos) @@ -298,7 +329,9 @@ text, microlens >= 0.3.0.0, microlens-th, - text-zipper + microlens-mtl, + text-zipper, + mtl executable brick-layer-demo if !flag(demos) @@ -312,7 +345,8 @@ vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-suspend-resume-demo if !flag(demos) @@ -365,6 +399,7 @@ brick, vty, text, + mtl, microlens executable brick-attr-demo @@ -392,6 +427,8 @@ vty, text, microlens >= 0.3.0.0, + microlens-mtl, + mtl, vector executable brick-list-vi-demo @@ -406,6 +443,8 @@ vty, text, microlens >= 0.3.0.0, + microlens-mtl, + mtl, vector executable brick-custom-event-demo @@ -420,7 +459,8 @@ vty, text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-fill-demo if !flag(demos) @@ -460,8 +500,10 @@ vty, text, vector, + mtl, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-border-demo if !flag(demos) @@ -503,7 +545,9 @@ brick, vty, text, - microlens + microlens, + microlens-mtl, + microlens-th test-suite brick-tests type: exitcode-stdio-1.0 diff --git a/docs/guide.rst b/docs/guide.rst --- a/docs/guide.rst +++ b/docs/guide.rst @@ -68,16 +68,17 @@ documentation and as you explore the library source and write your own programs. -- Use of `microlens`_ packages: ``brick`` uses ``microlens`` family of - packages internally and also exposes lenses for many types in the +- Use of `microlens`_ packages: ``brick`` uses the ``microlens`` family + of packages internally and also exposes lenses for many types in the library. However, if you prefer not to use the lens interface in your program, all lens interfaces have non-lens equivalents exported by the same module. In general, the "``L``" suffix on something tells you it is a lens; the name without the "``L``" suffix is the non-lens - version. You can get by without using ``brick``'s lens interface but - your life will probably be much more pleasant once your application - state becomes sufficiently complex if you use lenses to modify it (see - `appHandleEvent: Handling Events`_). + version. You can get by without using ``brick``'s lens interface + but your life will probably be much more pleasant if you use lenses + to modify your application state once it state becomes sufficiently + complex (see `appHandleEvent: Handling Events`_ and `Event Handlers + for Component State`_). - Attribute names: some modules export attribute names (see `How Attributes Work`_) associated with user interface elements. These tend to end in an "``Attr``" suffix (e.g. ``borderAttr``). In addition, @@ -96,8 +97,8 @@ Brick applications must be compiled with the threaded RTS using the GHC ``-threaded`` option. -The App Type -============ +The ``App`` Type +================ To use the library we must provide it with a value of type ``Brick.Main.App``. This type is a record type whose fields perform @@ -108,8 +109,8 @@ data App s e n = App { appDraw :: s -> [Widget n] , appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n) - , appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) - , appStartEvent :: s -> EventM n s + , appHandleEvent :: BrickEvent n e -> EventM n s () + , appStartEvent :: EventM n s () , appAttrMap :: s -> AttrMap } @@ -150,16 +151,16 @@ main :: IO () main = do - let app = App { ... } - initialState = ... - finalState <- defaultMain app initialState - -- Use finalState and exit + let app = App { ... } + initialState = ... + finalState <- defaultMain app initialState + -- Use finalState and exit The ``customMain`` function is for more advanced uses; for details see `Using Your Own Event Type`_. -appDraw: Drawing an Interface ------------------------------ +``appDraw``: Drawing an Interface +--------------------------------- The value of ``appDraw`` is a function that turns the current application state into a list of *layers* of type ``Widget``, listed @@ -201,116 +202,162 @@ ``Brick.Widgets.Core``. Beyond that, any module in the ``Brick.Widgets`` namespace provides specific kinds of functionality. -appHandleEvent: Handling Events -------------------------------- +``appHandleEvent``: Handling Events +----------------------------------- The value of ``appHandleEvent`` is a function that decides how to modify the application state as a result of an event: .. code:: haskell - appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) + appHandleEvent :: BrickEvent n e -> EventM n s () -The first parameter of type ``s`` is your application's state at the -time the event arrives. ``appHandleEvent`` is responsible for deciding -how to change the state based on the event and then return it. +``appHandleEvent`` is responsible for deciding how to change the state +based on the event. The single parameter to the event handler is the +event to be handled. Its type variables ``n`` and ``e`` correspond +to the *resource name type* and *event type* of your application, +respectively, and must match the corresponding types in ``App`` and +``EventM``. -The second parameter of type ``BrickEvent n e`` is the event itself. -The type variables ``n`` and ``e`` correspond to the *resource name -type* and *event type* of your application, respectively, and must match -the corresponding types in ``App`` and ``EventM``. +The ``EventM`` monad is parameterized on the *resource name type* +``n`` and your application's state type ``s``. The ``EventM`` monad +is a state monad over ``s``, so one way to access and modify your +application's state in an event handler is to use the ``MonadState`` +type class and associated operations from the ``mtl`` package. The +recommended approach, however, is to use the lens operations from the +``microlens-mtl`` package with lenses to perform concise state updates. +We'll cover this topic in more detail in `Event Handlers for Component +State`_. -The return value type ``Next s`` value describes what should happen -after the event handler is finished. We have four choices: +Once the event handler has performed any relevant state updates, it can +also indicate what should happen once the event handler has finished +executing. By default, after an event handler has completed, Brick will +redraw the screen with the application state (by calling ``appDraw``) +and wait for the next input event. However, there are two other options: -* ``Brick.Main.continue s``: continue executing the event loop with the - specified application state ``s`` as the next value. Commonly this is - where you'd modify the state based on the event and return it. -* ``Brick.Main.continueWithoutRedraw s``: continue executing the event - loop with the specified application state ``s`` as the next value, but - unlike ``continue``, do not redraw the screen using the new state. - This is a faster version of ``continue`` since it doesn't redraw the - screen; it just leaves up the previous screen contents. This function - is only useful when you know that your state change won't cause - anything on the screen to change. When in doubt, use ``continue``. -* ``Brick.Main.halt s``: halt the event loop and return the final - application state value ``s``. This state value is returned to the - caller of ``defaultMain`` or ``customMain`` where it can be used prior - to finally exiting ``main``. -* ``Brick.Main.suspendAndResume act``: suspend the ``brick`` event loop - and execute the specified ``IO`` action ``act``. The action ``act`` - must be of type ``IO s``, so when it executes it must return the next - application state. When ``suspendAndResume`` is used, the ``brick`` - event loop is shut down and the terminal state is restored to its - state when the ``brick`` event loop began execution. When it finishes - executing, the event loop will be resumed using the returned state - value. This is useful for situations where your program needs to - suspend your interface and execute some other program that needs to - gain control of the terminal (such as an external editor). +* ``Brick.Main.halt``: halt the event loop. The application state as it + exists after the event handler completes is returned to the caller + of ``defaultMain`` or ``customMain``. +* ``Brick.Main.continueWithoutRedraw``: continue executing the event + loop, but do not redraw the screen using the new state before waiting + for another input event. This is faster than the default continue + behavior since it doesn't redraw the screen; it just leaves up the + previous screen contents. This function is only useful when you know + that your event handler's state change(s) won't cause anything on + the screen to change. Use this only when you are certain that no + redraw of the screen is needed *and* when you are trying to address a + performance problem. (See also `The Rendering Cache`_ for details on + how to detail with rendering performance issues.) -The ``EventM`` monad is the event-handling monad. This monad is a -transformer around ``IO`` so you are free to do I/O in this monad by -using ``liftIO``. Beyond I/O, this monad is used to make scrolling -requests to the renderer (see `Viewports`_) and obtain named extents -(see `Extents`_). Keep in mind that time spent blocking in your event -handler is time during which your UI is unresponsive, so consider this -when deciding whether to have background threads do work instead of -inlining the work in the event handler. +The ``EventM`` monad is a transformer around ``IO`` so I/O is possible +in this monad by using ``liftIO``. Keep in mind, however, that event +handlers should execute as quickly as possible to avoid introducing +screen redraw latency. Consider using background threads to work +asynchronously when it would otherwise cause redraw latency. -Widget Event Handlers -********************* +Beyond I/O, ``EventM`` is used to make scrolling requests to the +renderer (see `Viewports`_), obtain named extents (see `Extents`_), and +other duties. -Event handlers are responsible for transforming the application state. -While you can use ordinary methods to do this such as pattern matching -and pure function calls, some widget state types such as the ones -provided by the ``Brick.Widgets.List`` and ``Brick.Widgets.Edit`` -modules provide their own widget-specific event-handling functions. -For example, ``Brick.Widgets.Edit`` provides ``handleEditorEvent`` and -``Brick.Widgets.List`` provides ``handleListEvent``. +Event Handlers for Component State +********************************** -Since these event handlers run in ``EventM``, they have access to -rendering viewport states via ``Brick.Main.lookupViewport`` and the -``IO`` monad via ``liftIO``. +The top-level ``appHandleEvent`` handler is responsible for managing +the application state, but it also needs to be able to update the state +associated with UI components such as those that come with Brick. -To use these handlers in your program, invoke them on the relevant piece -of state in your application state. In the following example we use an -``Edit`` state from ``Brick.Widgets.Edit``: +For example, consider an application that uses Brick's built-in text +editor from ``Brick.Widgets.Edit``. The built-in editor is similar to +the main application in that it has three important elements: -.. code:: haskell +* The editor state of type ``Editor t n``: this stores the editor's + contents, cursor position, etc. +* The editor's drawing function, ``renderEditor``: this is responsible + for drawing the editor in the UI. +* The editor's event handler, ``handleEditorEvent``: this is responsible + for updating the editor's contents and cursor position in response to + key events. - data Name = Edit1 - type MyState = Editor String Name +To use the built-in editor, the application must: - myEvent :: MyState -> BrickEvent n e -> EventM Name (Next MyState) - myEvent s (VtyEvent e) = continue =<< handleEditorEvent e s +* Embed an ``Editor t n`` somewhere in the application state ``s``, +* Render the editor's state at the appropriate place in ``appDraw`` with + ``renderEditor``, and +* Dispatch events to the editor in the ``appHandleEvent`` with + ``handleEditorEvent``. -This pattern works well enough when your application state has an -event handler as shown in the ``Edit`` example above, but it can -become unpleasant if the value on which you want to invoke a handler -is embedded deeply within your application state. If you have chosen -to generate lenses for your application state fields, you can use the -convenience function ``handleEventLensed`` by specifying your state, a -lens, and the event: +An example application state using an editor might look like this: .. code:: haskell - data Name = Edit1 - data MyState = MyState { _theEdit :: Editor String Name - } + data MyState = MyState { _editor :: Editor Text n } makeLenses ''MyState - myEvent :: MyState -> BrickEvent n e -> EventM Name (Next MyState) - myEvent s (VtyEvent e) = continue =<< handleEventLensed s theEdit handleEditorEvent e +This declares the ``MyState`` type with an ``Editor`` contained within +it and uses Template Haskell to generate a lens, ``editor``, to allow us +to easily update the editor state in our event handler. -You might consider that preferable to the desugared version: +To dispatch events to the ``editor`` we'd start by writing the +application event handler: .. code:: haskell - myEvent :: MyState -> BrickEvent n e -> EventM Name (Next MyState) - myEvent s (VtyEvent e) = do - newVal <- handleEditorEvent e (s^.theEdit) - continue $ s & theEdit .~ newVal + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + ... +But there's a problem: ``handleEditorEvent``'s type indicates that it +can only run over a state of type ``Editor t n``, but our handler runs +on ``MyState``. Specifically, ``handleEditorEvent`` has this type: + +.. code:: haskell + + handleEditorEvent :: BrickEvent n e -> EventM n (Editor t n) () + +This means that to use ``handleEditorEvent``, it must be composed +into the application's event handler, but since the state types ``s`` +and ``Editor t n`` do not match, we need a way to compose these event +handlers. There are two ways to do this: + +* Use ``Lens.Micro.Mtl.zoom`` from the ``microlens-mtl`` package + (re-exported by ``Brick.Types`` for convenience). This function is + required when you want to change the state type to a field embedded in + your application state using a lens. For example: + +.. code:: haskell + + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + zoom editor $ handleEditorEvent e + +* Use ``Brick.Types.nestEventM``: this function lets you provide a state + value and run ``EventM`` using that state. The following + ``nestEventM`` example is equivalent to the ``zoom`` example above: + +.. code:: haskell + + import Lens.Micro (_1) + import Lens.Micro.Mtl (use, (.=)) + + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + editorState <- use editor + (newEditorState, ()) <- nestEventM editorState $ do + handleEditorEvent e + editor .= newEditorState + +The ``zoom`` function, together with lenses for your application state's +fields, is by far the best way to manage your state in ``EventM``. As +you can see from the examples above, the ``zoom`` approach avoids a lot +of boilerplate. The ``nestEventM`` approach is provided in cases where +the state that you need to mutate is not easily accessed by ``zoom``. + +Finally, if you prefer to avoid the use of lenses, you can always use +the ``MonadState`` API to get, put, and modify your state. Keep in +mind that the ``MonadState`` approach will still require the use of +``nestEventM`` when events scoped to widget states such as ``Editor`` +need to be handled. + Using Your Own Event Type ************************* @@ -339,8 +386,8 @@ .. code:: haskell - myEvent :: s -> BrickEvent n CounterEvent -> EventM n (Next s) - myEvent s (AppEvent (Counter i)) = ... + myEvent :: BrickEvent n CounterEvent -> EventM n s () + myEvent (AppEvent (Counter i)) = ... The next step is to actually *generate* our custom events and inject them into the ``brick`` event stream so they make it to the @@ -391,8 +438,8 @@ your event handler when choosing the channel capacity and design event producers so that they can block if the channel is full. -appStartEvent: Starting up --------------------------- +``appStartEvent``: Starting up +------------------------------ When an application starts, it may be desirable to perform some of the duties typically only possible when an event has arrived, such as @@ -403,16 +450,17 @@ .. code:: haskell - appStartEvent :: s -> EventM n s + appStartEvent :: EventM n s () -This function takes the initial application state and returns it in -``EventM``, possibly changing it and possibly making viewport requests. -This function is invoked once and only once, at application startup. -For more details, see `Viewports`_. You will probably just want to use -``return`` as the implementation of this function for most applications. +This function is a handler action to run on the initial application +state. This function is invoked once and only once, at application +startup. This might be a place to make initial viewport scroll requests +or make changes to the Vty environment. You will probably just want +to use ``return ()`` as the implementation of this function for most +applications. -appChooseCursor: Placing the Cursor ------------------------------------ +``appChooseCursor``: Placing the Cursor +--------------------------------------- The rendering process for a ``Widget`` may return information about where that widget would like to place the cursor. For example, a text @@ -469,9 +517,10 @@ .. code:: haskell - myApp = App { ... - , appChooseCursor = \_ -> showCursorNamed CustomName - } + myApp = + App { ... + , appChooseCursor = \_ -> showCursorNamed CustomName + } See the next section for more information on using names. @@ -522,9 +571,8 @@ .. code:: haskell - do - let vp = viewportScroll Viewport1 - vScrollBy vp 1 + let vp = viewportScroll Viewport1 + vScrollBy vp 1 The solution is to ensure that for a given resource type (in this case viewport), a unique name is assigned in each use. @@ -537,8 +585,8 @@ ui = (viewport Viewport1 Vertical $ str "Foo") <+> (viewport Viewport2 Vertical $ str "Bar") <+> -appAttrMap: Managing Attributes -------------------------------- +``appAttrMap``: Managing Attributes +----------------------------------- In ``brick`` we use an *attribute map* to assign attributes to elements of the interface. Rather than specifying specific attributes when @@ -918,16 +966,20 @@ If the theme is further customized at runtime, any changes can be saved with ``Brick.Themes.saveCustomizations``. -Wide Character Support and the TextWidth class -============================================== +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 *only* work for single-column characters. So, for example, if you want @@ -937,26 +989,28 @@ let width = Data.Text.length t -because if the string contains any wide characters, their widths -will not be counted properly. In order to get this right, use the -``TextWidth`` type class to compute the width: +If the string contains any wide characters, their widths will not be +counted properly. In order to get this right, use the ``TextWidth`` type +class to compute the width: .. code:: haskell 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 width of a single character, use ``Graphics.Text.wcwidth``. +The ``TextWidth`` type class uses Vty's character width routine to +compute the width by looking up the string's characdters in a Unicode +width table. If you need to compute the width of a single character, use +``Graphics.Text.wcwidth``. Extents ======= -When an application needs to know where a particular widget was drawn by -the renderer, the application can request that the renderer record the -*extent* of the widget--its upper-left corner and size--and provide it -in an event handler. In the following example, the application needs to -know where the bordered box containing "Foo" is rendered: +When an application needs to know where a particular widget was drawn +by the renderer, the application can request that the renderer record +the *extent* of the widget--its upper-left corner and size--and provide +access to it in an event handler. Extents are represented using Brick's +``Brick.Types.Extent`` type. In the following example, the application +needs to know where the bordered box containing "Foo" is rendered: .. code:: haskell @@ -975,15 +1029,14 @@ reportExtent FooBox $ border $ str "Foo" -Now, whenever the ``ui`` is rendered, the location and size of the -bordered box containing "Foo" will be recorded. We can then look it up -in event handlers in ``EventM``: +Now, whenever the ``ui`` is rendered, the extent of the bordered box +containing "Foo" will be recorded. We can then look it up in event +handlers in ``EventM``: .. code:: haskell - do - mExtent <- Brick.Main.lookupExtent FooBox - case mExtent of + mExtent <- Brick.Main.lookupExtent FooBox + case mExtent of Nothing -> ... Just (Extent _ upperLeft (width, height)) -> ... @@ -1008,10 +1061,10 @@ import qualified Graphics.Vty as V do - vty <- Brick.Main.getVtyHandle - let output = V.outputIface vty - when (V.supportsMode output V.BracketedPaste) $ - liftIO $ V.setMode output V.BracketedPaste True + vty <- Brick.Main.getVtyHandle + let output = V.outputIface vty + when (V.supportsMode output V.BracketedPaste) $ + liftIO $ V.setMode output V.BracketedPaste True Once enabled, paste mode will generate Vty ``EvPaste`` events. These events will give you the entire pasted content as a ``ByteString`` which @@ -1029,10 +1082,10 @@ .. code:: haskell do - vty <- Brick.Main.getVtyHandle - let output = outputIface vty - when (supportsMode output Mouse) $ - liftIO $ setMode output Mouse True + vty <- Brick.Main.getVtyHandle + let output = outputIface vty + when (supportsMode output Mouse) $ + liftIO $ setMode output Mouse True Bear in mind that some terminals do not support mouse interaction, so use Vty's ``getModeStatus`` to find out whether your terminal will @@ -1053,7 +1106,7 @@ .. code:: haskell - handleEvent s (VtyEvent (EvMouseDown col row button mods) = ... + handleEvent (VtyEvent (EvMouseDown col row button mods) = ... Brick Mouse Events ------------------ @@ -1063,27 +1116,60 @@ language. The disadvantage to the low-level interface described above is that you still need to determine *what* was clicked, i.e., the part of the interface that was under the mouse cursor. There are two ways to do -this with ``brick``: with *extent checking* and *click reporting*. +this with ``brick``: with *click reporting* and *extent checking*. +Click reporting +*************** + +The *click reporting* approach is the most high-level approach offered +by ``brick`` and the one that we recommend you use. In this approach, +we use ``Brick.Widgets.Core.clickable`` when drawing the interface to +request that a given widget generate ``MouseDown`` and ``MouseUp`` +events when it is clicked. + +.. code:: haskell + + data Name = MyButton + + ui :: Widget Name + ui = center $ + clickable MyButton $ + border $ + str "Click me" + + handleEvent (MouseDown MyButton button modifiers coords) = ... + handleEvent (MouseUp MyButton button coords) = ... + +This approach enables event handlers to use pattern matching to check +for mouse clicks on specific regions; this uses `Extent checking`_ +under the hood but makes it possible to denote which widgets are +clickable in the interface description. The event's click coordinates +are local to the widget being clicked. In the above example, a click +on the upper-left corner of the border would result in coordinates of +``(0,0)``. + Extent checking *************** The *extent checking* approach entails requesting extents (see `Extents`_) for parts of your interface, then checking the Vty mouse -click event's coordinates against one or more extents. +click event's coordinates against one or more extents. This approach +is slightly lower-level than the direct mouse click reporting approach +above but is provided in case you need more control over how mouse +clicks are dealt with. The most direct way to do this is to check a specific extent: .. code:: haskell - handleEvent s (VtyEvent (EvMouseDown col row _ _)) = do - mExtent <- lookupExtent SomeExtent - case mExtent of - Nothing -> continue s - Just e -> do - if Brick.Main.clickedExtent (col, row) e - then ... - else ... + handleEvent (VtyEvent (EvMouseDown col row _ _)) = do + mExtent <- lookupExtent SomeExtent + case mExtent of + Nothing -> return () + Just e -> do + if Brick.Main.clickedExtent (col, row) e + then ... + else ... This approach works well enough if you know which extent you're interested in checking, but what if there are many extents and you @@ -1092,10 +1178,10 @@ .. code:: haskell - handleEvent s (VtyEvent (EvMouseDown col row _ _)) = do - extents <- Brick.Main.findClickedExtents (col, row) - -- Then check to see if a specific extent is in the list, or just - -- take the first one in the list. + handleEvent (VtyEvent (EvMouseDown col row _ _)) = do + extents <- Brick.Main.findClickedExtents (col, row) + -- Then check to see if a specific extent is in the list, or just + -- take the first one in the list. This approach finds all clicked extents and returns them in a list with the following properties: @@ -1109,35 +1195,6 @@ As a result, the extents are ordered in a natural way, starting with the most specific extents and proceeding to the most general. -Click reporting -*************** - -The *click reporting* approach is the most high-level approach -offered by ``brick``. When rendering the interface we use -``Brick.Widgets.Core.clickable`` to request that a given widget generate -``MouseDown`` and ``MouseUp`` events when it is clicked. - -.. code:: haskell - - data Name = MyButton - - ui :: Widget Name - ui = center $ - clickable MyButton $ - border $ - str "Click me" - - handleEvent s (MouseDown MyButton button modifiers coords) = ... - handleEvent s (MouseUp MyButton button coords) = ... - -This approach enables event handlers to use pattern matching to check -for mouse clicks on specific regions; this uses extent reporting -under the hood but makes it possible to denote which widgets are -clickable in the interface description. The event's click coordinates -are local to the widget being clicked. In the above example, a click -on the upper-left corner of the border would result in coordinates of -``(0,0)``. - Viewports ========= @@ -1210,14 +1267,14 @@ .. code:: haskell - hScrollPage :: Direction -> EventM n () - hScrollBy :: Int -> EventM n () - hScrollToBeginning :: EventM n () - hScrollToEnd :: EventM n () - vScrollPage :: Direction -> EventM n () - vScrollBy :: Int -> EventM n () - vScrollToBeginning :: EventM n () - vScrollToEnd :: EventM n () + hScrollPage :: Direction -> EventM n s () + hScrollBy :: Int -> EventM n s () + hScrollToBeginning :: EventM n s () + hScrollToEnd :: EventM n s () + vScrollPage :: Direction -> EventM n s () + vScrollBy :: Int -> EventM n s () + vScrollToBeginning :: EventM n s () + vScrollToEnd :: EventM n s () In each case the scrolling function scrolls the viewport by the specified amount in the specified direction; functions prefixed with @@ -1233,11 +1290,10 @@ .. code:: haskell - myHandler :: s -> e -> EventM n (Next s) - myHandler s e = do + myHandler :: e -> EventM n s () + myHandler e = do let vp = viewportScroll Viewport1 hScrollBy vp 1 - continue s Scrolling Viewports With Visibility Requests -------------------------------------------- @@ -1469,7 +1525,7 @@ .. code:: haskell (str "Name: " <+>) @@= - editTextField name NameField (Just 1) + editTextField name NameField (Just 1) Now when we invoke ``renderForm`` on a form using the above example, we'll see a ``"Name:"`` label to the left of the editor field for @@ -1504,14 +1560,14 @@ Handling Form Events -------------------- -Handling form events is easy: we just call -``Brick.Forms.handleFormEvent`` with the ``BrickEvent`` and the -``Form``. This automatically dispatches input events to the -currently-focused input field, and it also manages focus changes with -``Tab`` and ``Shift-Tab`` keybindings. (For details on all of its -behaviors, see the Haddock documentation for ``handleFormEvent``.) It's -still up to the application to decide when events should go to the form -in the first place. +Handling form events is easy: we just use ``zoom`` to call +``Brick.Forms.handleFormEvent`` with the ``BrickEvent`` and a lens +to access the ``Form`` in the application state. This automatically +dispatches input events to the currently-focused input field, and it +also manages focus changes with ``Tab`` and ``Shift-Tab`` keybindings. +(For details on all of its behaviors, see the Haddock documentation for +``handleFormEvent``.) It's still up to the application to decide when +events should go to the form in the first place. Since the form field handlers take ``BrickEvent`` values, that means that custom fields could even handle application-specific events (of the @@ -1557,6 +1613,80 @@ the ``FormFieldState`` and ``FormField`` data types along with the implementations of the built-in form field types. +Customizable Keybindings +======================== + +Brick applications typically start out by explicitly checking incoming +events for specific keys in ``appHandleEvent``. While this works well +enough, it results in *tight coupling* between the input key events and +the event handlers that get run. As applications evolve, it becomes +important to decouple the input key events and their handlers to allow +the input keys to be customized by the user. That's where Brick's +customizable keybindings API comes in. + +The customizable keybindings API provides: + +* ``Brick.Keybindings.Parse``: parsing and loading user-provided + keybinding configuration files, +* ``Brick.Keybindings.Pretty``: pretty-printing keybindings and + generating keybinding help text in ``Widget``, plain text, and + Markdown formats so you can provide help to users both within the + program and outside of it, +* ``Brick.Keybindings.KeyEvents``: specifying the application's abstract + key events and their configuration names, +* ``Brick.Keybindings.KeyConfig``: bundling default and customized + keybindings for each abstract event into a structure for use by the + dispatcher, and +* ``Brick.Keybindings.KeyDispatcher``: specifying handlers and + dispatching incoming key events to them. + +This section of the User Guide describes the API at a high level, +but Brick also provides a complete working example of the custom +keybinding API in ``programs/CustomKeybindingDemo.hs`` and +provides detailed documentation on how to use the API, including a +step-by-step process for using it, in the module documentation for +``Brick.Keybindings.KeyDispatcher``. + +The following table compares Brick application design decisions and +runtime behaviors in a typical application compared to one that uses the +customizable keybindings API: + ++---------------------+------------------------+-------------------------+ +| **Approach** | **Before runtime** | **At runtime** | ++---------------------+------------------------+-------------------------+ +| Typical application | The application author | #. An input event | +| (no custom | decides which keys will| arrives when the user| +| keybindings) | trigger application | presses a key. | +| | behaviors. The event | #. The event handler | +| | handler is written to | pattern-mathces on | +| | pattern-match on | the input event to | +| | specific keys. | check for a match and| +| | | then runs the | +| | | corresponding | +| | | handler. | ++---------------------+------------------------+-------------------------+ +| Application with | The application author | #. A Vty input event | +| custom keybindings | specifies the possible | arrives when the user| +| API integrated | *abstract events* that | presses a key. | +| | correspond to the | #. The input event is | +| | application's | provided to | +| | behaviors. The events | ``appHandleEvent``. | +| | are given default | #. ``appHandleEvent`` | +| | keybindings. The | passes the event on | +| | application provides | to a | +| | event handlers for the | ``KeyDispatcher``. | +| | abstract events, not | #. The key dispatcher | +| | specific keys. If | checks to see whether| +| | desired, the | the input key event | +| | application can load | maps to an abstract | +| | user-defined custom | event. | +| | keybindings from an INI| #. If the dispatcher | +| | file at startup to | finds a match, the | +| | override the | corresponding | +| | application's defaults.| abstract event's key | +| | | handler is run. | ++---------------------+------------------------+-------------------------+ + Joining Borders =============== @@ -1778,12 +1908,12 @@ .. code:: haskell - handleEvent s ... = do - -- Invalidate just a single cache entry: - Brick.Main.invalidateCacheEntry ExpensiveThing + handleEvent ... = do + -- Invalidate just a single cache entry: + Brick.Main.invalidateCacheEntry ExpensiveThing - -- Invalidate the entire cache (useful on a resize): - Brick.Main.invalidateCache + -- Invalidate the entire cache (useful on a resize): + Brick.Main.invalidateCache Implementing Custom Widgets =========================== @@ -1924,4 +2054,3 @@ .. _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/ diff --git a/docs/samtay-tutorial.md b/docs/samtay-tutorial.md deleted file mode 100644 --- a/docs/samtay-tutorial.md +++ /dev/null @@ -1,546 +0,0 @@ - -# Brick Tutorial by Samuel Tay - -This tutorial was written by Samuel Tay, Copyright 2017 -(https://github.com/samtay, https://samtay.github.io/). It is provided -as part of the brick distribution with permission. - -## Introduction - -I'm going to give a short introduction to -[brick](https://hackage.haskell.org/package/brick), a Haskell library -for building terminal user interfaces. So far I've used `brick` to -implement [Conway's Game of Life](https://github.com/samtay/conway) and -a [Tetris clone](https://github.com/samtay/tetris). I'll explain the -basics, walk through an example [snake](https://github.com/samtay/snake) -application, and then explain some more complicated scenarios. - -The first thing I'll say is that this package has some of the most -impressive documentation and resources, which makes it easy to figure -out pretty much anything you need to do. I'll try to make this useful, -but I imagine if you're reading this then it is mostly being used as a -reference in addition to the existing resources: - -1. [Demo programs](https://github.com/jtdaugherty/brick/tree/master/programs) -(clone down to explore the code and run them locally) -2. [User guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst) -3. [Haddock docs](https://hackage.haskell.org/package/brick) -4. [Google group](https://groups.google.com/forum/#!forum/brick-users) - -### The basic idea - -`brick` is very declarative. Once your base application logic is in -place, the interface is generally built by two functions: drawing and -handling events. The drawing function - -```haskell -appDraw :: s -> [Widget n] -``` - -takes your app state `s` and produces the visuals `[Widget n]`. The -handler - -```haskell -appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) -``` - -takes your app state, an event (e.g. user presses the `'m'` key), and -produces the resulting app state. *That's pretty much it.* - -## `snake` - -We're going to build the [classic -snake](https://en.wikipedia.org/wiki/Snake_(video_game)) game that you -might recall from arcades or the first cell phones. The full source code -is [here](https://github.com/samtay/snake). This is the end product: - -![](snake-demo.gif) - -### Structure of the app - -The library makes it easy to separate the concerns of your application -and the interface; I like to have a module with all of the core business -logic that exports the core state of the app and functions for modifying -it, and then have an interface module that just handles the setup, -drawing, and handling events. So let's just use the `simple` stack -template and add two modules - -``` -├── LICENSE -├── README.md -├── Setup.hs -├── snake.cabal -├── src -│   ├── Main.hs -│   ├── Snake.hs -│   └── UI.hs -└── stack.yaml -``` - -and our dependencies to `test.cabal` - -```yaml -executable snake - hs-source-dirs: src - main-is: Main.hs - ghc-options: -threaded - exposed-modules: Snake - , UI - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , brick - , containers - , linear - , microlens - , microlens-th - , random -``` - -### `Snake` - -Since this tutorial is about `brick`, I'll elide most of the -implementation details of the actual game, but here are some of the key -types and scaffolding: - -```haskell -{-# LANGUAGE TemplateHaskell, FlexibleContexts #-} -module Snake where - -import Control.Applicative ((<|>)) -import Control.Monad (guard) -import Data.Maybe (fromMaybe) - -import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|)) -import qualified Data.Sequence as S -import Lens.Micro.TH (makeLenses) -import Lens.Micro ((&), (.~), (%~), (^.)) -import Linear.V2 (V2(..), _x, _y) -import System.Random (Random(..), newStdGen) - --- Types - -data Game = Game - { _snake :: Snake -- ^ snake as a sequence of points in R2 - , _dir :: Direction -- ^ direction - , _food :: Coord -- ^ location of the food - , _foods :: Stream Coord -- ^ infinite list of random food locations - , _dead :: Bool -- ^ game over flag - , _paused :: Bool -- ^ paused flag - , _score :: Int -- ^ score - , _frozen :: Bool -- ^ freeze to disallow duplicate turns - } deriving (Show) - -type Coord = V2 Int -type Snake = Seq Coord - -data Stream a = a :| Stream a - deriving (Show) - -data Direction - = North - | South - | East - | West - deriving (Eq, Show) -``` - -All of this is pretty self-explanatory, with the possible exception -of lenses if you haven't seen them. At first glance they may seem -complicated (and the underlying theory arguably is), but using them as -getters and setters is very straightforward. So, if you are following -along because you are writing a terminal app like this, I'd recommend -using them, but they are not required to use `brick`. - -Here are the core functions for playing the game: - -```haskell --- | Step forward in time -step :: Game -> Game -step g = fromMaybe g $ do - guard (not $ g ^. paused || g ^. dead) - let g' = g & frozen .~ False - return . fromMaybe (move g') $ die g' <|> eatFood g' - --- | Possibly die if next head position is disallowed -die :: Game -> Maybe Game - --- | Possibly eat food if next head position is food -eatFood :: Game -> Maybe Game - --- | Move snake along in a marquee fashion -move :: Game -> Game - --- | Turn game direction (only turns orthogonally) --- --- Implicitly unpauses yet freezes game -turn :: Direction -> Game -> Game - --- | Initialize a paused game with random food location -initGame :: IO Game -``` - -### `UI` - -To start, we need to determine what our `App s e n` type parameters are. -This will completely describe the interface application and be passed -to one of the library's `main` style functions for execution. Note that -`s` is the app state, `e` is an event type, and `n` is a resource name. -The `e` is abstracted so that we can provide custom events. The `n` -is usually a custom sum type called `Name` which allows us to *name* -particular viewports. This is important so that we can keep track of -where the user currently has *focus*, such as typing in one of two -textboxes; however, for this simple snake game we don't need to worry -about that. - -In simpler cases, the state `s` can directly coincide with a core -datatype such as our `Snake.Game`. In many cases however, it will be -necessary to wrap the core state within the ui state `s` to keep track -of things that are interface specific (more on this later). - -Let's write out our app definition and leave some undefined functions: - -```haskell -{-# LANGUAGE OverloadedStrings #-} -module UI where - -import Control.Monad (forever, void) -import Control.Monad.IO.Class (liftIO) -import Control.Concurrent (threadDelay, forkIO) -import Data.Maybe (fromMaybe) - -import Snake - -import Brick - ( App(..), AttrMap, BrickEvent(..), EventM, Next, Widget - , customMain, neverShowCursor - , continue, halt - , hLimit, vLimit, vBox, hBox - , padRight, padLeft, padTop, padAll, Padding(..) - , withBorderStyle - , str - , attrMap, withAttr, emptyWidget, AttrName, on, fg - , (<+>) - ) -import Brick.BChan (newBChan, writeBChan) -import qualified Brick.Widgets.Border as B -import qualified Brick.Widgets.Border.Style as BS -import qualified Brick.Widgets.Center as C -import qualified Graphics.Vty as V -import Data.Sequence (Seq) -import qualified Data.Sequence as S -import Linear.V2 (V2(..)) -import Lens.Micro ((^.)) - --- Types - --- | Ticks mark passing of time --- --- This is our custom event that will be constantly fed into the app. -data Tick = Tick - --- | Named resources --- --- Not currently used, but will be easier to refactor --- if we call this "Name" now. -type Name = () - -data Cell = Snake | Food | Empty - --- App definition - -app :: App Game Tick Name -app = App { appDraw = drawUI - , appChooseCursor = neverShowCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } - -main :: IO () -main = undefined - --- Handling events - -handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) -handleEvent = undefined - --- Drawing - -drawUI :: Game -> [Widget Name] -drawUI = undefined - -theMap :: AttrMap -theMap = undefined -``` - -#### Custom Events - -So far I've only used `brick` to make games which need to be redrawn -as time passes, with or without user input. This requires using -`Brick.customMain` with that `Tick` event type, and opening a forked -process to `forever` feed that event type into the channel. Since this -is a common scenario, there is a `Brick.BChan` module that makes this -pretty quick: - -```haskell -main :: IO () -main = do - chan <- newBChan 10 - forkIO $ forever $ do - writeBChan chan Tick - threadDelay 100000 -- decides how fast your game moves - g <- initGame - let buildVty = V.mkVty V.defaultConfig - initialVty <- buildVty - void $ customMain initialVty buildVty (Just chan) app g -``` - -We do need to import `Vty.Graphics` since `customMain` allows us -to specify a custom `IO Vty.Graphics.Vty` handle, but we're only -customizing the existence of the event channel `BChan Tick`. The app -is now bootstrapped, and all we need to do is implement `handleEvent`, -`drawUI`, and `theMap` (handles styling). - -#### Handling events - -Handling events is largely straightforward, and can be very clean when -your underlying application logic is taken care of in a core module. All -we do is essentially map events to the proper state modifiers. - -```haskell -handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) -handleEvent g (AppEvent Tick) = continue $ step g -handleEvent g (VtyEvent (V.EvKey V.KUp [])) = continue $ turn North g -handleEvent g (VtyEvent (V.EvKey V.KDown [])) = continue $ turn South g -handleEvent g (VtyEvent (V.EvKey V.KRight [])) = continue $ turn East g -handleEvent g (VtyEvent (V.EvKey V.KLeft [])) = continue $ turn West g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'k') [])) = continue $ turn North g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'j') [])) = continue $ turn South g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'l') [])) = continue $ turn East g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'h') [])) = continue $ turn West g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'r') [])) = liftIO (initGame) >>= continue -handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g -handleEvent g (VtyEvent (V.EvKey V.KEsc [])) = halt g -handleEvent g _ = continue g -``` - -It's probably obvious, but `continue` will continue execution with -the supplied state value, which is then drawn. We can also `halt` to -stop execution, which will essentially finish the evaluation of our -`customMain` and result in `IO Game`, where the resulting game is the -last value that we supplied to `halt`. - -#### Drawing - -Drawing is fairly simple as well but can require a good amount of code -to position things how you want them. I like to break up the visual -space into regions with drawing functions for each one. - -```haskell -drawUI :: Game -> [Widget Name] -drawUI g = - [ C.center $ padRight (Pad 2) (drawStats g) <+> drawGrid g ] - -drawStats :: Game -> Widget Name -drawStats = undefined - -drawGrid :: Game -> Widget Name -drawGrid = undefined -``` - -This will center the overall interface (`C.center`), put the stats and -grid widgets horizontally side by side (`<+>`), and separate them by a -2-character width (`padRight (Pad 2)`). - -Let's move forward with the stats column: - -```haskell -drawStats :: Game -> Widget Name -drawStats g = hLimit 11 - $ vBox [ drawScore (g ^. score) - , padTop (Pad 2) $ drawGameOver (g ^. dead) - ] - -drawScore :: Int -> Widget Name -drawScore n = withBorderStyle BS.unicodeBold - $ B.borderWithLabel (str "Score") - $ C.hCenter - $ padAll 1 - $ str $ show n - -drawGameOver :: Bool -> Widget Name -drawGameOver dead = - if dead - then withAttr gameOverAttr $ C.hCenter $ str "GAME OVER" - else emptyWidget - -gameOverAttr :: AttrName -gameOverAttr = "gameOver" -``` - -I'm throwing in that `hLimit 11` to prevent the widget greediness caused -by the outer `C.center`. I'm also using `vBox` to show some other -options of aligning widgets; `vBox` and `hBox` align a list of widgets -vertically and horizontally, respectfully. They can be thought of as -folds over the binary `<=>` and `<+>` operations. - -The score is straightforward, but it is the first border in -this tutorial. Borders are well documented in the [border -demo](https://github.com/jtdaugherty/brick/blob/master/programs/BorderDemo.hs) -and the Haddocks for that matter. - -We also only show the "game over" widget if the game is actually over. -In that case, we are rendering the string widget with the `gameOverAttr` -attribute name. Attribute names are basically type safe *names* that -we can assign to widgets to apply predetermined styles, similar to -assigning a class name to a div in HTML and defining the CSS styles for -that class elsewhere. - -Attribute names implement `IsString`, so they are easy to construct with -the `OverloadedStrings` pragma. - -Now for the main event: - -```haskell -drawGrid :: Game -> Widget Name -drawGrid g = withBorderStyle BS.unicodeBold - $ B.borderWithLabel (str "Snake") - $ vBox rows - where - rows = [hBox $ cellsInRow r | r <- [height-1,height-2..0]] - cellsInRow y = [drawCoord (V2 x y) | x <- [0..width-1]] - drawCoord = drawCell . cellAt - cellAt c - | c `elem` g ^. snake = Snake - | c == g ^. food = Food - | otherwise = Empty - -drawCell :: Cell -> Widget Name -drawCell Snake = withAttr snakeAttr cw -drawCell Food = withAttr foodAttr cw -drawCell Empty = withAttr emptyAttr cw - -cw :: Widget Name -cw = str " " - -snakeAttr, foodAttr, emptyAttr :: AttrName -snakeAttr = "snakeAttr" -foodAttr = "foodAttr" -emptyAttr = "emptyAttr" - -``` - -There's actually nothing new here! We've already covered all the -`brick` functions necessary to draw the grid. My approach to grids is -to render a square cell widget `cw` with different colors depending -on the cell state. The easiest way to draw a colored square is to -stick two characters side by side. If we assign an attribute with a -matching foreground and background, then it doesn't matter what the two -characters are (provided that they aren't some crazy Unicode characters -that might render to an unexpected size). However, if we want empty -cells to render with the same color as the user's default background -color, then spaces are a good choice. - -Finally, we'll define the attribute map: - -```haskell -theMap :: AttrMap -theMap = attrMap V.defAttr - [ (snakeAttr, V.blue `on` V.blue) - , (foodAttr, V.red `on` V.red) - , (gameOverAttr, fg V.red `V.withStyle` V.bold) - ] -``` - -Again, styles aren't terribly complicated, but it -will be one area where you might have to look in the -[vty](http://hackage.haskell.org/package/vty) package (specifically -[Graphics.Vty.Attributes](http://hackage.haskell.org/package/vty-5.15.1/docs/Graphics-Vty-Attributes.html)) to find what you need. - -Another thing to mention is that the attributes form a hierarchy and -can be combined in a parent-child relationship via `mappend`. I haven't -actually used this feature, but it does sound quite handy. For a more -detailed discussion see the -[Brick.AttrMap](https://hackage.haskell.org/package/brick-0.18/docs/Brick-AttrMap.html) haddocks. - -## Variable speed - -One difficult problem I encountered was implementing a variable speed in -the GoL. I could have just used the same approach above with the minimum -thread delay (corresponding to the maximum speed) and counted `Tick` -events, only issuing an actual `step` in the game when the modular count -of `Tick`s reached an amount corresponding to the current game speed, -but that's kind of an ugly approach. - -Instead, I reached out to the author and he advised me to use a `TVar` -within the app state. I had never used `TVar`, but it's pretty easy! - -```haskell -main :: IO () -main = do - chan <- newBChan 10 - tv <- atomically $ newTVar (spToInt initialSpeed) - forkIO $ forever $ do - writeBChan chan Tick - int <- atomically $ readTVar tv - threadDelay int - let buildVty = V.mkVty V.defaultConfig - initialVty <- buildVty - customMain initialVty buildVty (Just chan) app (initialGame tv) - >>= printResult -``` - -The `tv <- atomically $ newTVar (value :: a)` creates a new mutable -reference to a value of type `a`, i.e. `TVar a`, and returns it in `IO`. -In this case `value` is an `Int` which represents the delay between game -steps. Then in the forked process, we read the delay from the `TVar` -reference and use that to space out the calls to `writeBChan chan Tick`. - -I store that same `tv :: TVar Int` in the brick app state, so that the -user can change the speed: - -```haskell -handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) -handleEvent g (VtyEvent (V.EvKey V.KRight [V.MCtrl])) = handleSpeed g (+) -handleEvent g (VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = handleSpeed g (-) - -handleSpeed :: Game -> (Float -> Float -> Float) -> EventM n (Next Game) -handleSpeed g (+/-) = do - let newSp = validS $ (g ^. speed) +/- speedInc - liftIO $ atomically $ writeTVar (g ^. interval) (spToInt newSp) - continue $ g & speed .~ newSp - --- where - --- | Speed increments = 0.01 gives 100 discrete speed settings -speedInc :: Float -speedInc = 0.01 - --- | Game state -data Game = Game - { _board :: Board -- ^ Board state - , _time :: Int -- ^ Time elapsed - , _paused :: Bool -- ^ Playing vs. paused - , _speed :: Float -- ^ Speed in [0..1] - , _interval :: TVar Int -- ^ Interval kept in TVar - , _focus :: F.FocusRing Name -- ^ Keeps track of grid focus - , _selected :: Cell -- ^ Keeps track of cell focus - } -``` - -## Conclusion - -`brick` let's you build TUIs very quickly. I was able to write `snake` -along with this tutorial within a few hours. More complicated interfaces -can be tougher, but if you can successfully separate the interface and -core functionality, you'll have an easier time tacking on the frontend. - -Lastly, let me remind you to look in the -[demo programs](https://github.com/jtdaugherty/brick/tree/master/programs) -to figure stuff out, as *many* scenarios are covered throughout them. - -## Links -* [brick](https://hackage.haskell.org/package/brick) -* [snake](https://github.com/samtay/snake) -* [tetris](https://github.com/samtay/tetris) -* [conway](https://github.com/samtay/conway) diff --git a/programs/AttrDemo.hs b/programs/AttrDemo.hs --- a/programs/AttrDemo.hs +++ b/programs/AttrDemo.hs @@ -23,28 +23,28 @@ , modifyDefAttr ) import Brick.Util (on, fg) -import Brick.AttrMap (attrMap, AttrMap) +import Brick.AttrMap (attrMap, AttrMap, attrName) ui :: Widget n ui = vBox [ str "This text uses the global default attribute." - , withAttr "foundFull" $ + , withAttr (attrName "foundFull") $ str "Specifying an attribute name means we look it up in the attribute tree." - , (withAttr "foundFgOnly" $ + , (withAttr (attrName "foundFgOnly") $ str ("When we find a value, we merge it with its parent in the attribute") <=> str "name tree all the way to the root (the global default).") - , withAttr "missing" $ + , withAttr (attrName "missing") $ str "A missing attribute name just resumes the search at its parent." - , withAttr ("general" <> "specific") $ + , withAttr (attrName "general" <> attrName "specific") $ str "In this way we build complete attribute values by using an inheritance scheme." - , withAttr "foundFull" $ + , withAttr (attrName "foundFull") $ str "You can override everything ..." - , withAttr "foundFgOnly" $ + , withAttr (attrName "foundFgOnly") $ str "... or only what you want to change and inherit the rest." , str "Attribute names are assembled with the Monoid append operation to indicate" , str "hierarchy levels, e.g. \"window\" <> \"title\"." , str " " - , withAttr "linked" $ + , withAttr (attrName "linked") $ str "This text is hyperlinked in terminals that support hyperlinking." , str " " , hyperlink "http://www.google.com/" $ @@ -59,18 +59,19 @@ theMap :: AttrMap theMap = attrMap globalDefault - [ ("foundFull", white `on` green) - , ("foundFgOnly", fg red) - , ("general", yellow `on` black) - , ("general" <> "specific", fg cyan) - , ("linked", fg yellow `withURL` "http://www.google.com/") + [ (attrName "foundFull", white `on` green) + , (attrName "foundFgOnly", fg red) + , (attrName "general", yellow `on` black) + , (attrName "general" <> attrName "specific", + fg cyan) + , (attrName "linked", fg yellow `withURL` "http://www.google.com/") ] app :: App () e () app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const theMap , appChooseCursor = neverShowCursor } diff --git a/programs/BorderDemo.hs b/programs/BorderDemo.hs --- a/programs/BorderDemo.hs +++ b/programs/BorderDemo.hs @@ -68,7 +68,7 @@ txt $ " " <> styleName <> " style " titleAttr :: A.AttrName -titleAttr = "title" +titleAttr = A.attrName "title" borderMappings :: [(A.AttrName, V.Attr)] borderMappings = diff --git a/programs/CacheDemo.hs b/programs/CacheDemo.hs --- a/programs/CacheDemo.hs +++ b/programs/CacheDemo.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} 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 +16,8 @@ , BrickEvent(..) ) import Brick.Widgets.Core - ( vBox + ( Padding(..) + , vBox , padTopBottom , withDefAttr , cached @@ -29,6 +30,7 @@ ) import Brick.AttrMap ( AttrName + , attrName , attrMap ) @@ -50,26 +52,26 @@ , 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" +emphAttr = attrName "emphasis" app :: M.App Int e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const $ attrMap V.defAttr [(emphAttr, V.white `on` V.blue)] , M.appChooseCursor = M.neverShowCursor diff --git a/programs/CroppingDemo.hs b/programs/CroppingDemo.hs --- a/programs/CroppingDemo.hs +++ b/programs/CroppingDemo.hs @@ -4,7 +4,6 @@ import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) import Brick.Types ( Widget - , Padding(..) ) import Brick.Widgets.Core ( vBox @@ -20,6 +19,7 @@ , cropRightTo , cropTopTo , cropBottomTo + , Padding(..) ) import Brick.Widgets.Border (border) import Brick.AttrMap (attrMap) @@ -52,7 +52,7 @@ app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] , appChooseCursor = neverShowCursor } diff --git a/programs/CustomEventDemo.hs b/programs/CustomEventDemo.hs --- a/programs/CustomEventDemo.hs +++ b/programs/CustomEventDemo.hs @@ -3,8 +3,9 @@ {-# LANGUAGE CPP #-} module Main where -import Lens.Micro ((^.), (&), (.~), (%~)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void, forever) import Control.Concurrent (threadDelay, forkIO) #if !(MIN_VERSION_base(4,11,0)) @@ -17,7 +18,6 @@ ( App(..) , showFirstCursor , customMain - , continue , halt ) import Brick.AttrMap @@ -25,7 +25,6 @@ ) import Brick.Types ( Widget - , Next , EventM , BrickEvent(..) ) @@ -50,14 +49,15 @@ <=> (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 @@ App { appDraw = drawUI , appChooseCursor = showFirstCursor , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] } diff --git a/programs/CustomKeybindingDemo.hs b/programs/CustomKeybindingDemo.hs new file mode 100644 --- /dev/null +++ b/programs/CustomKeybindingDemo.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Lens.Micro ((^.)) +import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl ((<~), (.=), (%=), use) +import Control.Monad (void) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Graphics.Vty as V +import System.Environment (getArgs) +import System.Exit (exitFailure) + +import qualified Brick.Types as T +import Brick.Types (Widget) +import qualified Brick.Keybindings as K +import Brick.AttrMap +import Brick.Util (fg) +import qualified Brick.Main as M +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Center as C +import Brick.Widgets.Core + +-- | The abstract key events for the application. +data KeyEvent = QuitEvent + | IncrementEvent + | DecrementEvent + deriving (Ord, Eq, Show) + +-- | The mapping of key events to their configuration field names. +allKeyEvents :: K.KeyEvents KeyEvent +allKeyEvents = + K.keyEvents [ ("quit", QuitEvent) + , ("increment", IncrementEvent) + , ("decrement", DecrementEvent) + ] + +-- | Default key bindings for each abstract key event. +defaultBindings :: [(KeyEvent, [K.Binding])] +defaultBindings = + [ (QuitEvent, [K.ctrl 'q', K.bind V.KEsc]) + , (IncrementEvent, [K.bind '+']) + , (DecrementEvent, [K.bind '-']) + ] + +data St = + St { _keyConfig :: K.KeyConfig KeyEvent + -- ^ The key config to use. + , _lastKey :: Maybe (V.Key, [V.Modifier]) + -- ^ The last key that was pressed. + , _lastKeyHandled :: Bool + -- ^ Whether the last key was handled by a handler. + , _counter :: Int + -- ^ The counter value to manipulate in the handlers. + , _customBindingsPath :: Maybe FilePath + -- ^ Set if the application found custom keybindings in the + -- specified file. + } + +makeLenses ''St + +-- | Key event handlers for our application. +handlers :: [K.KeyEventHandler KeyEvent (T.EventM () St)] +handlers = + -- The first three handlers are triggered by keys mapped to abstract + -- events, thus decoupling the configured key bindings from these + -- handlers. + [ K.onEvent QuitEvent "Quit the program" + M.halt + , K.onEvent IncrementEvent "Increment the counter" $ + counter %= succ + , K.onEvent DecrementEvent "Decrement the counter" $ + counter %= subtract 1 + + -- These handlers are always triggered by specific keys and thus + -- cannot be rebound. + , K.onKey (K.bind '\t') "Increment the counter by 10" $ + counter %= (+ 10) + , K.onKey (K.bind V.KBackTab) "Decrement the counter by 10" $ + counter %= subtract 10 + ] + +appEvent :: T.BrickEvent () e -> T.EventM () St () +appEvent (T.VtyEvent (V.EvKey k mods)) = do + -- Dispatch the key to the event handler to which the key is mapped, + -- if any. Also record in lastKeyHandled whether the dispatcher + -- found a matching handler. + kc <- use keyConfig + let d = K.keyDispatcher kc handlers + lastKey .= Just (k, mods) + lastKeyHandled <~ K.handleKey d k mods +appEvent _ = + return () + +drawUi :: St -> [Widget ()] +drawUi st = [body] + where + binding = uncurry K.binding <$> st^.lastKey + + -- Generate key binding help using the library so we can embed + -- it in the UI. + keybindingHelp = B.borderWithLabel (txt "Active Keybindings") $ + K.keybindingHelpWidget (st^.keyConfig) handlers + + lastKeyDisplay = withDefAttr lastKeyAttr $ + txt $ maybe "(none)" K.ppBinding binding + + -- Show the status of the last pressed key, whether we handled + -- it, and other bits of the application state. + status = B.borderWithLabel (txt "Status") $ + hLimit 40 $ + padRight Max $ + vBox [ txt "Last key: " <+> lastKeyDisplay + , str $ "Last key handled: " <> show (st^.lastKeyHandled) + , str $ "Counter: " <> show (st^.counter) + ] + + -- Show info about whether the application is currently using + -- custom bindings loaded from an INI file. + customBindingInfo = + B.borderWithLabel (txt "Custom Bindings") $ + case st^.customBindingsPath of + Nothing -> + hLimit 40 $ + txtWrap $ "No custom bindings loaded. Create an INI file with a " <> + (Text.pack $ show sectionName) <> + " section or use 'programs/custom_keys.ini'. " <> + "Pass its path to this program on the command line." + Just f -> str "Loaded custom bindings from:" <=> str (show f) + + body = C.center $ + (padRight (Pad 2) $ status <=> customBindingInfo) <+> + keybindingHelp + +lastKeyAttr :: AttrName +lastKeyAttr = attrName "lastKey" + +app :: M.App St e () +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = return () + , M.appHandleEvent = appEvent + , M.appAttrMap = const $ attrMap V.defAttr [ (K.eventNameAttr, fg V.magenta) + , (K.eventDescriptionAttr, fg V.cyan) + , (K.keybindingAttr, fg V.yellow) + , (lastKeyAttr, fg V.white `V.withStyle` V.bold) + ] + , M.appChooseCursor = M.showFirstCursor + } + +sectionName :: Text.Text +sectionName = "keybindings" + +main :: IO () +main = do + args <- getArgs + + -- If the command line specified the path to an INI file with custom + -- bindings, attempt to load it. + (customBindings, customFile) <- case args of + [iniFilePath] -> do + result <- K.keybindingsFromFile allKeyEvents sectionName iniFilePath + case result of + -- A section was found and had zero more bindings. + Right (Just bindings) -> + return (bindings, Just iniFilePath) + + -- No section was found at all. + Right Nothing -> do + putStrLn $ "Error: found no section " <> show sectionName <> " in " <> show iniFilePath + exitFailure + + -- There was some problem parsing the file as an INI + -- file. + Left e -> do + putStrLn $ "Error reading keybindings file " <> show iniFilePath <> ": " <> e + exitFailure + + _ -> return ([], Nothing) + + -- Create a key config that includes the default bindings as well as + -- the custom bindings we loaded from the INI file, if any. + let kc = K.newKeyConfig allKeyEvents defaultBindings customBindings + + void $ M.defaultMain app $ St { _keyConfig = kc + , _lastKey = Nothing + , _lastKeyHandled = False + , _counter = 0 + , _customBindingsPath = customFile + } + + -- Now demonstrate how the library's generated key binding help text + -- looks in plain text and Markdown formats. These can be used to + -- generate documentation for users. Note that the output generated + -- here takes the active bindings into account! If you don't want + -- that, use handlers that were built from a KeyConfig that didn't + -- have any custom bindings applied. + let sections = [("Main", handlers)] + + putStrLn "Generated plain text help:" + Text.putStrLn $ K.keybindingTextTable kc sections + + putStrLn "Generated Markdown help:" + Text.putStrLn $ K.keybindingMarkdownTable kc sections diff --git a/programs/DialogDemo.hs b/programs/DialogDemo.hs --- a/programs/DialogDemo.hs +++ b/programs/DialogDemo.hs @@ -30,13 +30,13 @@ 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 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs --- a/programs/EditDemo.hs +++ b/programs/EditDemo.hs @@ -5,6 +5,7 @@ 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 @@ 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 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = appCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/FileBrowserDemo.hs b/programs/FileBrowserDemo.hs --- a/programs/FileBrowserDemo.hs +++ b/programs/FileBrowserDemo.hs @@ -8,10 +8,11 @@ #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 -import Brick.AttrMap (AttrName) +import Brick.AttrMap (AttrName, attrName) import Brick.Types ( Widget , BrickEvent(..) @@ -27,6 +28,7 @@ ( 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 @@ 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,25 +57,27 @@ , 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" +errorAttr = attrName "error" theMap :: A.AttrMap theMap = A.attrMap V.defAttr @@ -95,7 +99,7 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/FormDemo.hs b/programs/FormDemo.hs --- a/programs/FormDemo.hs +++ b/programs/FormDemo.hs @@ -112,22 +112,24 @@ app :: App (Form UserInfo e Name) e Name app = App { appDraw = draw - , appHandleEvent = \s ev -> + , appHandleEvent = \ev -> do + f <- gets formFocus case ev of - VtyEvent (V.EvResize {}) -> continue s - VtyEvent (V.EvKey V.KEsc []) -> halt s + VtyEvent (V.EvResize {}) -> return () + VtyEvent (V.EvKey V.KEsc []) -> halt -- Enter quits only when we aren't in the multi-line editor. VtyEvent (V.EvKey V.KEnter []) - | focusGetCurrent (formFocus s) /= Just AddressField -> halt s + | focusGetCurrent f /= Just AddressField -> halt _ -> do - s' <- handleFormEvent ev s + handleFormEvent ev -- Example of external validation: -- Require age field to contain a value that is at least 18. - continue $ setFieldValid ((formState s')^.age >= 18) AgeField s' + st <- gets formState + modify $ setFieldValid (st^.age >= 18) AgeField , appChooseCursor = focusRingCursor formFocus - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const theMap } diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs --- a/programs/LayerDemo.hs +++ b/programs/LayerDemo.hs @@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} 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 @@ -30,6 +30,7 @@ import Brick.AttrMap ( attrMap , AttrName + , attrName ) data St = @@ -72,35 +73,35 @@ 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" +arrowAttr = attrName "attr" app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const $ attrMap V.defAttr [(arrowAttr, fg V.cyan)] , M.appChooseCursor = M.neverShowCursor diff --git a/programs/ListDemo.hs b/programs/ListDemo.hs --- a/programs/ListDemo.hs +++ b/programs/ListDemo.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} 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 +49,28 @@ , 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 = @@ -80,7 +83,7 @@ initialState = L.list () (Vec.fromList ['a','b','c']) 1 customAttr :: A.AttrName -customAttr = L.listSelectedAttr <> "custom" +customAttr = L.listSelectedAttr <> A.attrName "custom" theMap :: A.AttrMap theMap = A.attrMap V.defAttr @@ -94,7 +97,7 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/ListViDemo.hs b/programs/ListViDemo.hs --- a/programs/ListViDemo.hs +++ b/programs/ListViDemo.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} 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 +40,28 @@ , 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 = @@ -71,7 +74,7 @@ initialState = L.list () (Vec.fromList ['a','b','c']) 1 customAttr :: A.AttrName -customAttr = L.listSelectedAttr <> "custom" +customAttr = L.listSelectedAttr <> A.attrName "custom" theMap :: A.AttrMap theMap = A.attrMap V.defAttr @@ -85,7 +88,7 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} {-# 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,15 +44,15 @@ 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)) where buttons = mkButton <$> buttonData - buttonData = [ (Button1, "Button 1", "button1") - , (Button2, "Button 2", "button2") - , (Button3, "Button 3", "button3") + buttonData = [ (Button1, "Button 1", attrName "button1") + , (Button2, "Button 2", attrName "button2") + , (Button3, "Button 3", attrName "button3") ] mkButton (name, label, attr) = let wasClicked = (fst <$> st^.lastReportedClick) == Just name @@ -80,35 +81,41 @@ Just (name, T.Location l) -> "Mouse down at " <> show name <> " @ " <> show l T.render $ translateBy (T.Location (0, h-1)) $ clickable Info $ - withDefAttr "info" $ + withDefAttr (attrName "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 - [ ("info", V.white `on` V.magenta) - , ("button1", V.white `on` V.cyan) - , ("button2", V.white `on` V.green) - , ("button3", V.white `on` V.blue) + [ (attrName "info", V.white `on` V.magenta) + , (attrName "button1", V.white `on` V.cyan) + , (attrName "button2", V.white `on` V.green) + , (attrName "button3", V.white `on` V.blue) , (E.editFocusedAttr, V.black `on` V.yellow) ] 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 +123,7 @@ 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." diff --git a/programs/PaddingDemo.hs b/programs/PaddingDemo.hs --- a/programs/PaddingDemo.hs +++ b/programs/PaddingDemo.hs @@ -4,7 +4,6 @@ import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) import Brick.Types ( Widget - , Padding(..) ) import Brick.Widgets.Core ( vBox @@ -17,6 +16,7 @@ , padBottom , padTopBottom , padLeftRight + , Padding(..) ) import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Center as C @@ -49,7 +49,7 @@ app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] , appChooseCursor = neverShowCursor } diff --git a/programs/ProgressBarDemo.hs b/programs/ProgressBarDemo.hs --- a/programs/ProgressBarDemo.hs +++ b/programs/ProgressBarDemo.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} module Main where import Control.Monad (void) @@ -7,6 +8,8 @@ import 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,8 +26,10 @@ ) 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] where @@ -33,16 +38,16 @@ (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 @@ 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 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/SuspendAndResumeDemo.hs b/programs/SuspendAndResumeDemo.hs --- a/programs/SuspendAndResumeDemo.hs +++ b/programs/SuspendAndResumeDemo.hs @@ -3,7 +3,7 @@ {-# LANGUAGE CPP #-} module Main where -import Lens.Micro ((.~), (^.), (&)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) import Control.Monad (void) #if !(MIN_VERSION_base(4,11,0)) @@ -13,7 +13,7 @@ import Brick.Main ( App(..), neverShowCursor, defaultMain - , suspendAndResume, halt, continue + , suspendAndResume, halt ) import Brick.AttrMap ( attrMap @@ -21,7 +21,6 @@ import Brick.Types ( Widget , EventM - , Next , BrickEvent(..) ) import Brick.Widgets.Core @@ -42,16 +41,16 @@ , 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 @@ App { appDraw = drawUI , appChooseCursor = neverShowCursor , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] } diff --git a/programs/TailDemo.hs b/programs/TailDemo.hs --- a/programs/TailDemo.hs +++ b/programs/TailDemo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where #if !(MIN_VERSION_base(4,11,0)) @@ -7,6 +8,8 @@ import 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.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 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 @@ , "cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." ] -handleEvent :: AppState -> BrickEvent n CustomEvent -> EventM n (Next AppState) -handleEvent s (AppEvent (NewLine l)) = - continue $ s { textAreaContents = l : textAreaContents s } -handleEvent s (VtyEvent (V.EvKey V.KUp [])) = - continue $ s { textAreaHeight = textAreaHeight s + 1 } -handleEvent s (VtyEvent (V.EvKey V.KDown [])) = - continue $ s { textAreaHeight = max 0 $ textAreaHeight s - 1 } -handleEvent s (VtyEvent (V.EvKey V.KRight [])) = - continue $ s { textAreaWidth = textAreaWidth s + 1 } -handleEvent s (VtyEvent (V.EvKey V.KLeft [])) = - continue $ s { textAreaWidth = max 0 $ textAreaWidth s - 1 } -handleEvent s (VtyEvent (V.EvKey V.KEsc [])) = - halt s -handleEvent s _ = - continue s +handleEvent :: BrickEvent n CustomEvent -> EventM n AppState () +handleEvent (AppEvent (NewLine l)) = + textAreaContents %= (l :) +handleEvent (VtyEvent (V.EvKey V.KUp [])) = + textAreaHeight %= (+ 1) +handleEvent (VtyEvent (V.EvKey V.KDown [])) = + textAreaHeight %= max 0 . subtract 1 +handleEvent (VtyEvent (V.EvKey V.KRight [])) = + textAreaWidth %= (+ 1) +handleEvent (VtyEvent (V.EvKey V.KLeft [])) = + textAreaWidth %= max 0 . subtract 1 +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = + halt +handleEvent _ = + return () data CustomEvent = NewLine T.Text -data AppState = - AppState { textAreaHeight :: Int - , textAreaWidth :: Int - , textAreaContents :: [T.Text] - } - app :: App AppState CustomEvent () app = App { appDraw = (:[]) . draw , appChooseCursor = neverShowCursor , appHandleEvent = handleEvent , appAttrMap = const $ attrMap V.defAttr [] - , appStartEvent = return + , appStartEvent = return () } initialState :: AppState initialState = - AppState { textAreaHeight = 20 - , textAreaWidth = 40 - , textAreaContents = [] + AppState { _textAreaHeight = 20 + , _textAreaWidth = 40 + , _textAreaContents = [] } -- | Run forever, generating new lines of text for the application diff --git a/programs/ThemeDemo.hs b/programs/ThemeDemo.hs --- a/programs/ThemeDemo.hs +++ b/programs/ThemeDemo.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} 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 +18,6 @@ ( Widget , BrickEvent(VtyEvent) , EventM - , Next ) import Brick.Widgets.Center ( hCenter @@ -32,7 +31,7 @@ , withDefAttr ) import Brick.Util (on, fg) -import Brick.AttrMap (AttrName) +import Brick.AttrMap (AttrName, attrName) ui :: Widget n ui = @@ -44,7 +43,7 @@ ] keybindingAttr :: AttrName -keybindingAttr = "keybinding" +keybindingAttr = attrName "keybinding" theme1 :: Theme theme1 = @@ -58,18 +57,18 @@ [ (keybindingAttr, fg yellow) ] -appEvent :: Int -> BrickEvent () e -> EventM () (Next Int) -appEvent _ (VtyEvent (EvKey (KChar '1') [])) = continue 1 -appEvent _ (VtyEvent (EvKey (KChar '2') [])) = continue 2 -appEvent s (VtyEvent (EvKey (KChar 'q') [])) = halt s -appEvent s (VtyEvent (EvKey KEsc [])) = halt s -appEvent s _ = continue s +appEvent :: BrickEvent () e -> EventM () Int () +appEvent (VtyEvent (EvKey (KChar '1') [])) = put 1 +appEvent (VtyEvent (EvKey (KChar '2') [])) = put 2 +appEvent (VtyEvent (EvKey (KChar 'q') [])) = halt +appEvent (VtyEvent (EvKey KEsc [])) = halt +appEvent _ = return () app :: App Int e () app = App { appDraw = const [ui] , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = \s -> -- Note that in practice this is not ideal: we don't want -- to build an attribute from a theme every time this is diff --git a/programs/ViewportScrollDemo.hs b/programs/ViewportScrollDemo.hs --- a/programs/ViewportScrollDemo.hs +++ b/programs/ViewportScrollDemo.hs @@ -59,22 +59,22 @@ 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 diff --git a/programs/ViewportScrollbarsDemo.hs b/programs/ViewportScrollbarsDemo.hs --- a/programs/ViewportScrollbarsDemo.hs +++ b/programs/ViewportScrollbarsDemo.hs @@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where +import Lens.Micro.TH +import Lens.Micro.Mtl import Control.Monad (void) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) @@ -26,7 +29,8 @@ , attrMap ) import Brick.Widgets.Core - ( hLimit + ( Padding(..) + , hLimit , vLimit , padRight , hBox @@ -57,17 +61,19 @@ 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] where 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 @@ 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 @@ _ -> 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 @@ app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const theme , M.appChooseCursor = M.neverShowCursor diff --git a/programs/VisibilityDemo.hs b/programs/VisibilityDemo.hs --- a/programs/VisibilityDemo.hs +++ b/programs/VisibilityDemo.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Main where @@ -6,6 +5,7 @@ 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 @@ -15,7 +15,7 @@ import qualified Brick.Main as M import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B -import Brick.AttrMap (AttrMap, AttrName, attrMap) +import Brick.AttrMap (AttrMap, AttrName, attrMap, attrName) import Brick.Util (on) import Brick.Types ( Widget @@ -55,7 +55,7 @@ vp3Size = (25, 25) selectedAttr :: AttrName -selectedAttr = "selected" +selectedAttr = attrName "selected" drawUi :: St -> [Widget Name] drawUi st = [ui] @@ -102,17 +102,17 @@ 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 +122,7 @@ 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 diff --git a/programs/custom_keys.ini b/programs/custom_keys.ini new file mode 100644 --- /dev/null +++ b/programs/custom_keys.ini @@ -0,0 +1,4 @@ +[keybindings] +quit = x +increment = i +decrement = d diff --git a/src/Brick/AttrMap.hs b/src/Brick/AttrMap.hs --- a/src/Brick/AttrMap.hs +++ b/src/Brick/AttrMap.hs @@ -2,9 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} -- | This module provides types and functions for managing an attribute -- map which maps attribute names ('AttrName') to attributes ('Attr'). --- This module is designed to be used with the 'OverloadedStrings' --- language extension to permit easy construction of 'AttrName' values --- and you should also use 'mappend' ('<>') to combine names. -- -- Attribute maps work by mapping hierarchical attribute names to -- attributes and inheriting parent names' attributes when child names @@ -52,7 +49,6 @@ import qualified Data.Map as M import Data.Maybe (catMaybes) import Data.List (inits) -import Data.String (IsString(..)) import GHC.Generics (Generic) import Graphics.Vty (Attr(..), MaybeDefault(..), Style) @@ -65,9 +61,9 @@ -- example: -- -- @ --- "window" <> "border" --- "window" <> "title" --- "header" <> "clock" <> "seconds" +-- attrName "window" <> attrName "border" +-- attrName "window" <> attrName "title" +-- attrName "header" <> attrName "clock" <> attrName "seconds" -- @ data AttrName = AttrName [String] deriving (Show, Read, Eq, Ord, Generic, NFData) @@ -78,9 +74,6 @@ instance Monoid AttrName where mempty = AttrName [] mappend = (Sem.<>) - -instance IsString AttrName where - fromString = AttrName . (:[]) -- | An attribute map which maps 'AttrName' values to 'Attr' values. data AttrMap = AttrMap Attr (M.Map AttrName Attr) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -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 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 @@ -- ^ 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 @@ -- ^ 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 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 @@ 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 @@ [(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,10 +482,11 @@ csr = if foc then putCursor name (Location (1,0)) else id in clickable name $ addAttr $ csr $ - hBox [ txt $ T.singleton lb - , txt $ if isSet then T.singleton check else " " - , txt $ T.singleton rb <> " " <> label - ] + txt $ T.concat $ + [ T.singleton lb + , if isSet then T.singleton check else " " + , T.singleton rb <> " " <> label + ] -- | A form field for using an editor to edit the text representation of -- a value. The other editing fields in this module are special cases of @@ -638,15 +642,15 @@ -- | The namespace for the other form attributes. formAttr :: AttrName -formAttr = "brickForm" +formAttr = attrName "brickForm" -- | The attribute for form input fields with invalid values. invalidFormInputAttr :: AttrName -invalidFormInputAttr = formAttr <> "invalidInput" +invalidFormInputAttr = formAttr <> attrName "invalidInput" -- | The attribute for form input fields that have the focus. focusedFormInputAttr :: AttrName -focusedFormInputAttr = formAttr <> "focusedInput" +focusedFormInputAttr = formAttr <> attrName "focusedInput" -- | Returns whether all form fields in the form currently have valid -- values according to the fields' validation functions. This is useful @@ -729,8 +733,8 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ result <- findField fields case result of Nothing -> findFieldState (prev <> [e]) es - Just (newSt, maybeSt) -> + Just (newSt, maybeSt) -> do let newFieldState = FormFieldState newSt stLens upd fields helper concatAll - in return $ f { formFieldStates = prev <> [newFieldState] <> es - , formState = case maybeSt of - Nothing -> formState f - Just s -> formState f & stLens .~ s - } + formFieldStatesL .= prev <> [newFieldState] <> es + case maybeSt of + Nothing -> return () + Just s -> formStateL.stLens .= s + + states <- gets formFieldStates + findFieldState [] states diff --git a/src/Brick/Keybindings.hs b/src/Brick/Keybindings.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings.hs @@ -0,0 +1,20 @@ +-- | The re-exporting catch-all module for the customizable keybindings +-- API. +-- +-- To get started using this API, see the documentation in +-- @KeyDispatcher@ as well as the User Guide section on customizable +-- keybindings. +module Brick.Keybindings + ( module Brick.Keybindings.KeyEvents + , module Brick.Keybindings.KeyConfig + , module Brick.Keybindings.KeyDispatcher + , module Brick.Keybindings.Pretty + , module Brick.Keybindings.Parse + ) +where + +import Brick.Keybindings.KeyEvents +import Brick.Keybindings.KeyConfig +import Brick.Keybindings.KeyDispatcher +import Brick.Keybindings.Pretty +import Brick.Keybindings.Parse diff --git a/src/Brick/Keybindings/KeyConfig.hs b/src/Brick/Keybindings/KeyConfig.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/KeyConfig.hs @@ -0,0 +1,203 @@ +-- | This module provides 'KeyConfig' and associated functions. A +-- 'KeyConfig' is the basis for the custom keybinding system in this +-- library. +-- +-- To get started, see 'newKeyConfig'. Once a 'KeyConfig' has been +-- constructed, see 'Brick.Keybindings.KeyHandlerMap.keyDispatcher'. +module Brick.Keybindings.KeyConfig + ( KeyConfig + , newKeyConfig + , BindingState(..) + + -- * Specifying bindings + , Binding(..) + , ToBinding(..) + , binding + , fn + , meta + , ctrl + , shift + + -- * Querying KeyConfigs + , firstDefaultBinding + , firstActiveBinding + , allDefaultBindings + , allActiveBindings + + -- * Misc + , keyConfigEvents + , lookupKeyConfigBindings + ) +where + +import Data.List (nub) +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Graphics.Vty as Vty + +import Brick.Keybindings.KeyEvents + +-- | A key binding. +-- +-- The easiest way to express 'Binding's is to use the helper functions +-- in this module that work with instances of 'ToBinding', e.g. +-- +-- @ +-- let ctrlB = 'ctrl' \'b\' +-- shiftX = 'shift' \'x\' +-- ctrlMetaK = 'ctrl' $ 'meta' \'k\' +-- -- Or with Vty keys directly: +-- ctrlDown = 'ctrl' 'Graphics.Vty.Input.KDown' +-- @ +data Binding = + Binding { kbKey :: Vty.Key + -- ^ The key itself. + , kbMods :: S.Set Vty.Modifier + -- ^ The set of modifiers. + } deriving (Eq, Show, Ord) + +-- | Construct a 'Binding'. Modifier order is ignored. +binding :: Vty.Key -> [Vty.Modifier] -> Binding +binding k mods = + Binding { kbKey = k + , kbMods = S.fromList mods + } + +-- | An explicit configuration of key bindings for a key event. +data BindingState = + BindingList [Binding] + -- ^ Bind the event to the specified list of bindings. + | Unbound + -- ^ Disable all bindings for the event, including default bindings. + deriving (Show, Eq, Ord) + +-- | A configuration of custom key bindings. A 'KeyConfig' +-- stores everything needed to resolve a key event into one or +-- more key bindings. Make a 'KeyConfig' with 'newKeyConfig', +-- then use it to dispatch to 'KeyEventHandler's with +-- 'Brick.Keybindings.KeyHandlerMap.keyDispatcher'. +-- +-- Make a new 'KeyConfig' with 'newKeyConfig'. +-- +-- A 'KeyConfig' stores: +-- +-- * A collection of named key events, mapping the event type @k@ to +-- 'Text' labels. +-- * For each event @k@, optionally store a list of default key bindings +-- for that event. +-- * An optional customized binding list for each event, setting the +-- event to either 'Unbound' or providing explicit overridden bindings +-- with 'BindingList'. +data KeyConfig k = + KeyConfig { keyConfigBindingMap :: M.Map k BindingState + -- ^ The map of custom bindings for events with custom + -- bindings. + , keyConfigEvents :: KeyEvents k + -- ^ The base mapping of events and their names that is + -- used in this configuration. + , keyConfigDefaultBindings :: M.Map k [Binding] + -- ^ A mapping of events and their default key bindings, + -- if any. + } + deriving (Show, Eq) + +-- | Build a 'KeyConfig' with the specified 'KeyEvents' event-to-name +-- mapping, list of default bindings by event, and list of custom +-- bindings by event. +newKeyConfig :: (Ord k) + => KeyEvents k + -- ^ The base mapping of key events and names to use. + -> [(k, [Binding])] + -- ^ Default bindings by key event, such as from a + -- configuration file or embedded code. Optional on a + -- per-event basis. + -> [(k, BindingState)] + -- ^ Custom bindings by key event, such as from a + -- configuration file. Explicitly setting an event to + -- 'Unbound' here has the effect of disabling its default + -- bindings. Optional on a per-event basis. + -> KeyConfig k +newKeyConfig evs defaults bindings = + KeyConfig { keyConfigBindingMap = M.fromList bindings + , keyConfigEvents = evs + , keyConfigDefaultBindings = M.fromList defaults + } + +-- | Look up the binding state for the specified event. This returns +-- 'Nothing' when the event has no explicitly configured custom +-- 'BindingState'. +lookupKeyConfigBindings :: (Ord k) => KeyConfig k -> k -> Maybe BindingState +lookupKeyConfigBindings kc e = M.lookup e $ keyConfigBindingMap kc + +-- | A convenience function to return the first result of +-- 'allDefaultBindings', if any. +firstDefaultBinding :: (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding +firstDefaultBinding kc ev = do + bs <- M.lookup ev (keyConfigDefaultBindings kc) + case bs of + (b:_) -> Just b + _ -> Nothing + +-- | Returns the list of default bindings for the specified event, +-- irrespective of whether the event has been explicitly configured with +-- other bindings or set to 'Unbound'. +allDefaultBindings :: (Ord k) => KeyConfig k -> k -> [Binding] +allDefaultBindings kc ev = + fromMaybe [] $ M.lookup ev (keyConfigDefaultBindings kc) + +-- | A convenience function to return the first result of +-- 'allActiveBindings', if any. +firstActiveBinding :: (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding +firstActiveBinding kc ev = listToMaybe $ allActiveBindings kc ev + +-- | Return all active key bindings for the specified event. This +-- returns customized bindings if any have been set in the 'KeyConfig', +-- no bindings if the event has been explicitly set to 'Unbound', or the +-- default bindings if the event is absent from the customized bindings. +allActiveBindings :: (Show k, Ord k) => KeyConfig k -> k -> [Binding] +allActiveBindings kc ev = nub foundBindings + where + defaultBindings = allDefaultBindings kc ev + foundBindings = case lookupKeyConfigBindings kc ev of + Just (BindingList bs) -> bs + Just Unbound -> [] + Nothing -> defaultBindings + +-- | The class of types that can form the basis of 'Binding's. +-- +-- This is provided to make it easy to write and modify bindings in less +-- verbose ways. +class ToBinding a where + -- | Binding constructor. + bind :: a -> Binding + +instance ToBinding Vty.Key where + bind k = Binding { kbMods = mempty, kbKey = k } + +instance ToBinding Char where + bind = bind . Vty.KChar + +instance ToBinding Binding where + bind = id + +addModifier :: (ToBinding a) => Vty.Modifier -> a -> Binding +addModifier m val = + let b = bind val + in b { kbMods = S.insert m (kbMods b) } + +-- | Add Meta to a binding. +meta :: (ToBinding a) => a -> Binding +meta = addModifier Vty.MMeta + +-- | Add Ctrl to a binding. +ctrl :: (ToBinding a) => a -> Binding +ctrl = addModifier Vty.MCtrl + +-- | Add Shift to a binding. +shift :: (ToBinding a) => a -> Binding +shift = addModifier Vty.MShift + +-- | Function key binding. +fn :: Int -> Binding +fn = bind . Vty.KFun diff --git a/src/Brick/Keybindings/KeyDispatcher.hs b/src/Brick/Keybindings/KeyDispatcher.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/KeyDispatcher.hs @@ -0,0 +1,220 @@ +-- | This is the entry point into the keybinding infrastructure in +-- this library. Note that usage of this API is not required to create +-- working Brick applications; this API is provided for applications +-- that need to support custom keybindings that are less tightly coupled +-- to application behavior. +-- +-- The workflow for this API is as follows: +-- +-- * Create a data type @k@ with a constructor for each abstract +-- application event that you want to trigger with an input key. +-- * To each event @k@, assign a unique user-readable name (such as a +-- name you could imagine using in a configuration file to refer to +-- the event) and a list of default key bindings. +-- * Use the resulting data to create a 'KeyConfig' with 'newKeyConfig'. +-- If desired, provide custom keybindings to 'newKeyConfig' from +-- within the program or load them from an INI file with routines like +-- 'Brick.Keybindings.Parse.keybindingsFromFile'. +-- * Implement application event handlers that will be run in response +-- to either specific hard-coded keys or events @k@, both in some +-- monad @m@ of your choosing, using constructors 'onKey' and +-- 'onEvent'. +-- * Use the created 'KeyConfig' and handlers to create a +-- 'KeyDispatcher' with 'keyDispatcher'. +-- * As user input events arrive, dispatch them to the appropriate +-- handler using 'handleKey'. +module Brick.Keybindings.KeyDispatcher + ( -- * Key dispatching + KeyDispatcher + , keyDispatcher + , handleKey + + -- * Building handlers + , onEvent + , onKey + + -- * Handlers and triggers + , Handler(..) + , KeyHandler(..) + , KeyEventHandler(..) + , EventTrigger(..) + + -- * Misc + , keyDispatcherToList + , lookupVtyEvent + ) +where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Graphics.Vty as Vty + +import Brick.Keybindings.KeyConfig + +-- | A set of handlers for specific keys whose handlers run in the monad +-- @m@. +newtype KeyDispatcher k m = KeyDispatcher (M.Map Binding (KeyHandler k m)) + +-- | An 'Handler' represents a handler implementation to be invoked in +-- response to some event that runs in the monad @m@. +-- +-- In general, you should never need to make one of these manually. +-- Instead, use 'onEvent' and 'onKey'. This type's internals are exposed +-- for easy inspection, not construction. +data Handler m = + Handler { handlerDescription :: T.Text + -- ^ The description of this handler's behavior. + , handlerAction :: m () + -- ^ The action to take when this handler is invoked. + } + +-- | A handler for a specific key. +-- +-- In general, you should never need to create one of these. The +-- internals are exposed to make inspection easy. +data KeyHandler k m = + KeyHandler { khHandler :: KeyEventHandler k m + -- ^ The handler to invoke. Note that this maintains + -- the original abstract key event handler; this allows + -- us to obtain the original 'EventTrigger' for the + -- 'KeyEventHandler' upon which this 'KeyHandler' + -- is built. This can be important for keybinding + -- consistency checks or collision checks as well as help + -- text generation. + , khBinding :: Binding + -- ^ The specific key binding that should trigger this + -- handler. + } + +-- | Find the key handler that matches a Vty key event, if any. Modifier +-- order is unimportant since the lookup for a matching binding ignores +-- modifier order. +-- +-- This works by looking up an event handler whose binding is the +-- specified key and modifiers based on the 'KeyConfig' that was used to +-- build the 'KeyDispatcher'. +-- +-- Ordinarily you will not need to use this function; use 'handleKey' +-- instead. This is provided for more direct access to the +-- 'KeyDispatcher' internals. +lookupVtyEvent :: Vty.Key -> [Vty.Modifier] -> KeyDispatcher k m -> Maybe (KeyHandler k m) +lookupVtyEvent k mods (KeyDispatcher m) = M.lookup (Binding k $ S.fromList mods) m + +-- | Handle a keyboard event by looking it up in the 'KeyDispatcher' +-- and invoking the matching binding's handler if one is found. Return +-- @True@ if the a matching handler was found and run; return @False@ if +-- no matching binding was found. +handleKey :: (Monad m) + => KeyDispatcher k m + -- ^ The dispatcher to use. + -> Vty.Key + -- ^ The key to handle. + -> [Vty.Modifier] + -- ^ The modifiers for the key, if any. + -> m Bool +handleKey d k mods = do + case lookupVtyEvent k mods d of + Just kh -> (handlerAction $ kehHandler $ khHandler kh) >> return True + Nothing -> return False + +-- | Build a 'KeyDispatcher' to dispatch keys to handle events of type +-- @k@ using actions in a Monad @m@. +-- +-- This works by taking a list of abstract 'KeyEventHandler's and +-- building a 'KeyDispatcher' of event handlers based on specific Vty +-- keys using the provided 'KeyConfig' to map between abstract key +-- events of type @k@ and Vty keys. Event handlers triggered by an event +-- @k@ are set up to be triggered by either the customized bindings for +-- @k@ in the 'KeyConfig', no bindings at all if the 'KeyConfig' has +-- marked @k@ as 'Unbound', or the default bindings for @k@ otherwise. +-- +-- Once you have a 'KeyDispatcher', you can dispatch an input key event +-- to it and invoke the corresponding handler (if any) with 'handleKey'. +keyDispatcher :: (Ord k) + => KeyConfig k + -> [KeyEventHandler k m] + -> KeyDispatcher k m +keyDispatcher conf ks = KeyDispatcher $ M.fromList $ buildKeyDispatcherPairs ks conf + +-- | Convert a key dispatcher to a list of pairs of bindings and their +-- handlers. +keyDispatcherToList :: KeyDispatcher k m + -> [(Binding, KeyHandler k m)] +keyDispatcherToList (KeyDispatcher m) = M.toList m + +buildKeyDispatcherPairs :: (Ord k) + => [KeyEventHandler k m] + -> KeyConfig k + -> [(Binding, KeyHandler k m)] +buildKeyDispatcherPairs ks conf = pairs + where + pairs = mkPair <$> handlers + mkPair h = (khBinding h, h) + handlers = concat $ keyHandlersFromConfig conf <$> ks + +keyHandlersFromConfig :: (Ord k) + => KeyConfig k + -> KeyEventHandler k m + -> [KeyHandler k m] +keyHandlersFromConfig kc eh = + let allBindingsFor ev | Just (BindingList ks) <- lookupKeyConfigBindings kc ev = ks + | Just Unbound <- lookupKeyConfigBindings kc ev = [] + | otherwise = allDefaultBindings kc ev + bindings = case kehEventTrigger eh of + ByKey b -> [b] + ByEvent ev -> allBindingsFor ev + in [ KeyHandler { khHandler = eh, khBinding = b } | b <- bindings ] + +mkHandler :: T.Text -> m () -> Handler m +mkHandler msg action = + Handler { handlerDescription = msg + , handlerAction = action + } + +-- | Specify a handler for the specified key event. +onEvent :: k + -- ^ The key event whose bindings should trigger this handler. + -> T.Text + -- ^ The description of the handler. + -> m () + -- ^ The handler to invoke. + -> KeyEventHandler k m +onEvent ev msg action = + KeyEventHandler { kehHandler = mkHandler msg action + , kehEventTrigger = ByEvent ev + } + +-- | Specify a handler for the specified key. +onKey :: (ToBinding a) + => a + -- ^ The binding that should trigger this handler. + -> T.Text + -- ^ The description of the handler. + -> m () + -- ^ The handler to invoke. + -> KeyEventHandler k m +onKey b msg action = + KeyEventHandler { kehHandler = mkHandler msg action + , kehEventTrigger = ByKey $ bind b + } + +-- | A trigger for an event handler. +data EventTrigger k = + ByKey Binding + -- ^ The key event is always triggered by a specific key. + | ByEvent k + -- ^ The trigger is an abstract key event. + deriving (Show, Eq, Ord) + +-- | A handler for an abstract key event. +-- +-- In general, you should never need to create these manually. Instead, +-- use 'onEvent' and 'onKey'. The internals of this type are exposed to +-- allow inspection of handler data for e.g. custom help generation. +data KeyEventHandler k m = + KeyEventHandler { kehHandler :: Handler m + -- ^ The handler to invoke. + , kehEventTrigger :: EventTrigger k + -- ^ The trigger for the handler. + } diff --git a/src/Brick/Keybindings/KeyEvents.hs b/src/Brick/Keybindings/KeyEvents.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/KeyEvents.hs @@ -0,0 +1,52 @@ +-- | This module provides 'KeyEvents', a data type for mapping +-- application-defined abstract events to user-facing names (e.g. +-- for use in configuration files and documentation). This data +-- structure gives you a place to define the correspondence between +-- your application's key events and their names. A 'KeyEvents' also +-- effectively tells the key binding system about the collection of +-- possible abstract events that can be handled. +-- +-- A 'KeyEvents' is used to construct a +-- 'Brick.Keybindings.KeyConfig.KeyConfig' with +-- 'Brick.Keybindings.KeyConfig.newKeyConfig'. +module Brick.Keybindings.KeyEvents + ( KeyEvents + , keyEvents + , keyEventsList + , lookupKeyEvent + , keyEventName + ) +where + +import qualified Data.Bimap as B +import qualified Data.Text as T + +-- | A bidirectional mapping between events @k@ and their user-readable +-- names. +data KeyEvents k = KeyEvents (B.Bimap T.Text k) + deriving (Eq, Show) + +-- | Build a new 'KeyEvents' map from the specified list of events and +-- names. Key event names are stored in lowercase. +-- +-- Calls 'error' if any events have the same name (ignoring case) or if +-- multiple names map to the same event. +keyEvents :: (Ord k) => [(T.Text, k)] -> KeyEvents k +keyEvents pairs = + let m = B.fromList [(T.strip $ T.toLower n, e) | (n, e) <- pairs] + in if B.size m /= length pairs + then error "keyEvents: input list contains duplicates by name or by event value" + else KeyEvents $ B.fromList pairs + +-- | Convert the 'KeyEvents' to a list. +keyEventsList :: KeyEvents k -> [(T.Text, k)] +keyEventsList (KeyEvents m) = B.toList m + +-- | Look up the specified event name to get its abstract event. The +-- lookup ignores leading and trailing whitespace as well as case. +lookupKeyEvent :: (Ord k) => KeyEvents k -> T.Text -> Maybe k +lookupKeyEvent (KeyEvents m) name = B.lookup (T.strip $ T.toLower name) m + +-- | Given an abstract event, get its event name. +keyEventName :: (Ord k) => KeyEvents k -> k -> Maybe T.Text +keyEventName (KeyEvents m) e = B.lookupR e m diff --git a/src/Brick/Keybindings/Parse.hs b/src/Brick/Keybindings/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/Parse.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides key binding string parsing functions for use +-- in e.g. reading key bindings from configuration files. +module Brick.Keybindings.Parse + ( parseBinding + , parseBindingList + + , keybindingsFromIni + , keybindingsFromFile + , keybindingIniParser + ) +where + +import Control.Monad (forM) +import Data.Maybe (catMaybes) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Graphics.Vty as Vty +import Text.Read (readMaybe) +import qualified Data.Ini.Config as Ini + +import Brick.Keybindings.KeyEvents +import Brick.Keybindings.KeyConfig + +-- | Parse a key binding list into a 'BindingState'. +-- +-- A key binding list either the string @"unbound"@ or is a +-- comma-separated list of 'Binding's parsed with 'parseBinding'. +parseBindingList :: T.Text -> Either String BindingState +parseBindingList t = + if T.toLower t == "unbound" + then return Unbound + else BindingList <$> mapM (parseBinding . T.strip) (T.splitOn "," $ T.strip t) + +-- | Parse a key binding string. Key binding strings specify zero or +-- more modifier keys and a base key, separated by hyphens. +-- +-- @ +-- (modifier "-")* key +-- @ +-- +-- e.g. @c-down@, @backspace@, @ctrl-shift-f1@. +-- +-- where each @modifier@ is parsed case-insensitively as follows: +-- +-- * @"s", "shift"@: 'Vty.MShift' +-- * @"m", "meta"@: 'Vty.MMeta' +-- * @"a", "alt"@: 'Vty.MAlt' +-- * @"c", "ctrl", "control"@: 'Vty.MCtrl' +-- +-- and @key@ is parsed case-insensitively as follows: +-- +-- * "f1", "f2", ...: 'Vty.KFun' +-- * "esc": 'Vty.KEsc' +-- * "backspace": 'Vty.KBS' +-- * "enter": 'Vty.KEnter' +-- * "left": 'Vty.KLeft' +-- * "right": 'Vty.KRight' +-- * "up": 'Vty.KUp' +-- * "down": 'Vty.KDown' +-- * "upleft": 'Vty.KUpLeft' +-- * "upright": 'Vty.KUpRight' +-- * "downleft": 'Vty.KDownLeft' +-- * "downright": 'Vty.KDownRight' +-- * "center": 'Vty.KCenter' +-- * "backtab": 'Vty.KBackTab' +-- * "printscreen": 'Vty.KPrtScr' +-- * "pause": 'Vty.KPause' +-- * "insert": 'Vty.KIns' +-- * "home": 'Vty.KHome' +-- * "pgup": 'Vty.KPageUp' +-- * "del": 'Vty.KDel' +-- * "end": 'Vty.KEnd' +-- * "pgdown": 'Vty.KPageDown' +-- * "begin": 'Vty.KBegin' +-- * "menu": 'Vty.KMenu' +-- * "space": @' '@ +-- * "tab": @'\\t'@ +-- * Otherwise, 'Vty.KChar' +parseBinding :: T.Text -> Either String Binding +parseBinding s = go (T.splitOn "-" $ T.toLower s) [] + where go [k] mods = do + k' <- pKey k + return Binding { kbMods = S.fromList mods, kbKey = k' } + go (k:ks) mods = do + m <- case k of + "s" -> return Vty.MShift + "shift" -> return Vty.MShift + "m" -> return Vty.MMeta + "meta" -> return Vty.MMeta + "a" -> return Vty.MAlt + "alt" -> return Vty.MAlt + "c" -> return Vty.MCtrl + "ctrl" -> return Vty.MCtrl + "control" -> return Vty.MCtrl + _ -> Left ("Unknown modifier prefix: " ++ show k) + go ks (m:mods) + go [] _ = Left "Empty keybinding not allowed" + pKey "esc" = return Vty.KEsc + pKey "backspace" = return Vty.KBS + pKey "enter" = return Vty.KEnter + pKey "left" = return Vty.KLeft + pKey "right" = return Vty.KRight + pKey "up" = return Vty.KUp + pKey "down" = return Vty.KDown + pKey "upleft" = return Vty.KUpLeft + pKey "upright" = return Vty.KUpRight + pKey "downleft" = return Vty.KDownLeft + pKey "downright" = return Vty.KDownRight + pKey "center" = return Vty.KCenter + pKey "backtab" = return Vty.KBackTab + pKey "printscreen" = return Vty.KPrtScr + pKey "pause" = return Vty.KPause + pKey "insert" = return Vty.KIns + pKey "home" = return Vty.KHome + pKey "pgup" = return Vty.KPageUp + pKey "del" = return Vty.KDel + pKey "end" = return Vty.KEnd + pKey "pgdown" = return Vty.KPageDown + pKey "begin" = return Vty.KBegin + pKey "menu" = return Vty.KMenu + pKey "space" = return (Vty.KChar ' ') + pKey "tab" = return (Vty.KChar '\t') + pKey t + | T.length t == 1 = + return (Vty.KChar $ T.last s) + | Just n <- T.stripPrefix "f" t = + case readMaybe (T.unpack n) of + Nothing -> Left ("Unknown keybinding: " ++ show t) + Just i -> return (Vty.KFun i) + | otherwise = Left ("Unknown keybinding: " ++ show t) + +-- | Parse custom key bindings from the specified INI file using the +-- provided event name mapping. +-- +-- Each line in the specified section can take the form +-- +-- > = <"unbound"|[binding,...]> +-- +-- where the event name must be a valid event name in the specified +-- 'KeyEvents' and each binding is valid as parsed by 'parseBinding'. +-- +-- Returns @Nothing@ if the named section was not found; otherwise +-- returns a (possibly empty) list of binding states for each event in +-- @evs@. +keybindingsFromIni :: KeyEvents k + -- ^ The key event name mapping to use to parse the + -- configuration data. + -> T.Text + -- ^ The name of the INI configuration section to + -- read. + -> T.Text + -- ^ The text of the INI document to read. + -> Either String (Maybe [(k, BindingState)]) +keybindingsFromIni evs section doc = + Ini.parseIniFile doc (keybindingIniParser evs section) + +-- | Parse custom key binidngs from the specified INI file path. This +-- does not catch or convert any exceptions resulting from I/O errors. +-- See 'keybindingsFromIni' for details. +keybindingsFromFile :: KeyEvents k + -- ^ The key event name mapping to use to parse the + -- configuration data. + -> T.Text + -- ^ The name of the INI configuration section to + -- read. + -> FilePath + -- ^ The path to the INI file to read. + -> IO (Either String (Maybe [(k, BindingState)])) +keybindingsFromFile evs section path = + keybindingsFromIni evs section <$> T.readFile path + +-- | The low-level INI parser for custom key bindings used by this +-- module, exported for applications that use the @config-ini@ package. +keybindingIniParser :: KeyEvents k -> T.Text -> Ini.IniParser (Maybe [(k, BindingState)]) +keybindingIniParser evs section = + Ini.sectionMb section $ do + fmap catMaybes $ forM (keyEventsList evs) $ \(name, e) -> do + fmap (e,) <$> Ini.fieldMbOf name parseBindingList diff --git a/src/Brick/Keybindings/Pretty.hs b/src/Brick/Keybindings/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/Pretty.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides functions for pretty-printing key bindings +-- and for generating Markdown, plain text, and Brick displays of event +-- handler key binding configurations. +module Brick.Keybindings.Pretty + ( + -- * Generating help output + keybindingTextTable + , keybindingMarkdownTable + , keybindingHelpWidget + + -- * Pretty-printing primitives + , ppBinding + , ppMaybeBinding + , ppKey + , ppModifier + + -- * Attributes for Widget rendering + , keybindingHelpBaseAttr + , eventNameAttr + , eventDescriptionAttr + , keybindingAttr + ) +where + +import Brick +import Data.List (sort, intersperse) +import Data.Maybe (fromJust) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Graphics.Vty as Vty + +import Brick.Keybindings.KeyEvents +import Brick.Keybindings.KeyConfig +import Brick.Keybindings.KeyDispatcher + +data TextHunk = Verbatim T.Text + | Comment T.Text + +-- | Generate a Markdown document of sections indicating the key binding +-- state for each event handler. +keybindingMarkdownTable :: (Ord k) + => KeyConfig k + -- ^ The key binding configuration in use. + -> [(T.Text, [KeyEventHandler k m])] + -- ^ Key event handlers by named section. + -> T.Text +keybindingMarkdownTable kc sections = title <> keybindSectionStrings + where title = "# Keybindings\n" + keybindSectionStrings = T.concat $ sectionText <$> sections + sectionText (heading, handlers) = + mkHeading heading <> + mkKeybindEventSectionHelp kc keybindEventHelpMarkdown T.unlines handlers + mkHeading n = + "\n# " <> n <> + "\n| Keybinding | Event Name | Description |" <> + "\n| ---------- | ---------- | ----------- |\n" + +-- | Generate a plain text document of sections indicating the key +-- binding state for each event handler. +keybindingTextTable :: (Ord k) + => KeyConfig k + -- ^ The key binding configuration in use. + -> [(T.Text, [KeyEventHandler k m])] + -- ^ Key event handlers by named section. + -> T.Text +keybindingTextTable kc sections = title <> keybindSectionStrings + where title = "Keybindings\n===========\n" + keybindSectionStrings = T.concat $ sectionText <$> sections + sectionText (heading, handlers) = + mkHeading heading <> + mkKeybindEventSectionHelp kc (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines handlers + keybindingWidth = 15 + eventNameWidth = 30 + mkHeading n = + "\n" <> n <> + "\n" <> (T.replicate (T.length n) "=") <> + "\n" + +keybindEventHelpText :: Int -> Int -> (TextHunk, T.Text, [TextHunk]) -> T.Text +keybindEventHelpText width eventNameWidth (evName, desc, evs) = + let getText (Comment s) = s + getText (Verbatim s) = s + in padTo width (T.intercalate ", " $ getText <$> evs) <> " " <> + padTo eventNameWidth (getText evName) <> " " <> + desc + +padTo :: Int -> T.Text -> T.Text +padTo n s = s <> T.replicate (n - T.length s) " " + +mkKeybindEventSectionHelp :: (Ord k) + => KeyConfig k + -> ((TextHunk, T.Text, [TextHunk]) -> a) + -> ([a] -> a) + -> [KeyEventHandler k m] + -> a +mkKeybindEventSectionHelp kc mkKeybindHelpFunc vertCat kbs = + vertCat $ mkKeybindHelpFunc <$> (mkKeybindEventHelp kc <$> kbs) + +keybindEventHelpMarkdown :: (TextHunk, T.Text, [TextHunk]) -> T.Text +keybindEventHelpMarkdown (evName, desc, evs) = + let quote s = "`" <> s <> "`" + format (Comment s) = s + format (Verbatim s) = quote s + name = case evName of + Comment s -> s + Verbatim s -> quote s + in "| " <> (T.intercalate ", " $ format <$> evs) <> + " | " <> name <> + " | " <> desc <> + " |" + +mkKeybindEventHelp :: (Ord k) + => KeyConfig k + -> KeyEventHandler k m + -> (TextHunk, T.Text, [TextHunk]) +mkKeybindEventHelp kc h = + let trig = kehEventTrigger h + unbound = [Comment "(unbound)"] + (label, evText) = case trig of + ByKey b -> + (Comment "(non-customizable key)", [Verbatim $ ppBinding b]) + ByEvent ev -> + let name = fromJust $ keyEventName (keyConfigEvents kc) ev + in case lookupKeyConfigBindings kc ev of + Nothing -> + if not (null (allDefaultBindings kc ev)) + then (Verbatim name, Verbatim <$> ppBinding <$> allDefaultBindings kc ev) + else (Verbatim name, unbound) + Just Unbound -> + (Verbatim name, unbound) + Just (BindingList bs) -> + let result = if not (null bs) + then Verbatim <$> ppBinding <$> bs + else unbound + in (Verbatim name, result) + in (label, handlerDescription $ kehHandler h, evText) + +-- | Build a 'Widget' displaying key binding information for a single +-- related group of event handlers. This is provided for convenience +-- so that basic help text for the application's event handlers can be +-- produced and embedded in the UI. +-- +-- The resulting widget lists the key events (and keys) bound to the +-- specified handlers, along with the events' names and the list of +-- available key bindings for each handler. +keybindingHelpWidget :: (Ord k) + => KeyConfig k + -- ^ The key binding configuration in use. + -> [KeyEventHandler k m] + -- ^ The list of the event handlers to include in + -- the help display. + -> Widget n +keybindingHelpWidget kc = + withDefAttr keybindingHelpBaseAttr . + mkKeybindEventSectionHelp kc keybindEventHelpWidget (vBox . intersperse (str " ")) + +keybindEventHelpWidget :: (TextHunk, T.Text, [TextHunk]) -> Widget n +keybindEventHelpWidget (evName, desc, evs) = + let evText = T.intercalate ", " (getText <$> evs) + getText (Comment s) = s + getText (Verbatim s) = s + label = withDefAttr eventNameAttr $ case evName of + Comment s -> txt s -- TODO: was "; " <> s + Verbatim s -> txt s -- TODO: was: emph $ txt s + in vBox [ withDefAttr eventDescriptionAttr $ txt desc + , label <+> txt " = " <+> withDefAttr keybindingAttr (txt evText) + ] + +-- | Pretty-print a 'Binding' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppBinding :: Binding -> T.Text +ppBinding (Binding k mods) = + T.intercalate "-" $ (ppModifier <$> modifierList mods) <> [ppKey k] + +modifierList :: S.Set Vty.Modifier -> [Vty.Modifier] +modifierList = sort . S.toList + +-- | Pretty-print a 'Binding' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'; if no binding is given, +-- produce a message indicating no binding. +ppMaybeBinding :: Maybe Binding -> T.Text +ppMaybeBinding Nothing = + "(no binding)" +ppMaybeBinding (Just b) = + ppBinding b + +-- | Pretty-print a 'Vty.Key' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppKey :: Vty.Key -> T.Text +ppKey (Vty.KChar c) = ppChar c +ppKey (Vty.KFun n) = "F" <> (T.pack $ show n) +ppKey Vty.KBackTab = "BackTab" +ppKey Vty.KEsc = "Esc" +ppKey Vty.KBS = "Backspace" +ppKey Vty.KEnter = "Enter" +ppKey Vty.KUp = "Up" +ppKey Vty.KDown = "Down" +ppKey Vty.KLeft = "Left" +ppKey Vty.KRight = "Right" +ppKey Vty.KHome = "Home" +ppKey Vty.KEnd = "End" +ppKey Vty.KPageUp = "PgUp" +ppKey Vty.KPageDown = "PgDown" +ppKey Vty.KDel = "Del" +ppKey Vty.KUpLeft = "UpLeft" +ppKey Vty.KUpRight = "UpRight" +ppKey Vty.KDownLeft = "DownLeft" +ppKey Vty.KDownRight = "DownRight" +ppKey Vty.KCenter = "Center" +ppKey Vty.KPrtScr = "PrintScreen" +ppKey Vty.KPause = "Pause" +ppKey Vty.KIns = "Insert" +ppKey Vty.KBegin = "Begin" +ppKey Vty.KMenu = "Menu" + +-- | Pretty-print a character in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppChar :: Char -> T.Text +ppChar '\t' = "Tab" +ppChar ' ' = "Space" +ppChar c = T.singleton c + +-- | Pretty-print a 'Vty.Modifier' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppModifier :: Vty.Modifier -> T.Text +ppModifier Vty.MMeta = "M" +ppModifier Vty.MAlt = "A" +ppModifier Vty.MCtrl = "C" +ppModifier Vty.MShift = "S" + +-- | The base attribute for 'Widget' keybinding help. +keybindingHelpBaseAttr :: AttrName +keybindingHelpBaseAttr = attrName "keybindingHelp" + +-- | The attribute for event names in keybinding help 'Widget's. +eventNameAttr :: AttrName +eventNameAttr = keybindingHelpBaseAttr <> attrName "eventName" + +-- | The attribute for event descriptions in keybinding help 'Widget's. +eventDescriptionAttr :: AttrName +eventDescriptionAttr = keybindingHelpBaseAttr <> attrName "eventDescription" + +-- | The attribute for keybinding lists in keybinding help 'Widget's. +keybindingAttr :: AttrName +keybindingAttr = keybindingHelpBaseAttr <> attrName "keybinding" diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Brick.Main ( App(..) , defaultMain @@ -9,10 +10,10 @@ , simpleApp -- * Event handler functions - , continue , continueWithoutRedraw , halt , suspendAndResume + , suspendAndResume' , makeVisible , lookupViewport , lookupExtent @@ -53,10 +54,8 @@ 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.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 @@ -- 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 w = App { appDraw = const [w] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap defAttr [] , appChooseCursor = neverShowCursor } @@ -169,46 +168,40 @@ -- 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 -- after the application halts. @@ -267,22 +260,19 @@ -- ^ 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 @@ , 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 @@ -- 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 @@ _ -> 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 @@ -- 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 @@ -- | 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 @@ -- 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 @@ 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 @@ (cloc^.locationRowL) } - update vty picWithCursor + update (vtyContextHandle vtyCtx) picWithCursor return (newRS, exts) @@ -509,38 +535,38 @@ 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 @@ -559,11 +585,6 @@ } -- | 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 -- be really sure that you don't want a screen redraw. If your state @@ -571,30 +592,51 @@ -- '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 }) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -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 @@ , ScrollbarRenderer(..) , ClickableScrollbarElement(..) - -- * Event-handling types - , EventM(..) - , Next + -- * Event-handling types and functions + , EventM , BrickEvent(..) - , handleEventLensed + , nestEventM + , nestEventM' -- * Rendering infrastructure , RenderM @@ -85,63 +84,72 @@ -- * 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 +-- | 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 + } + ((actResult, newSt), stInnerFinal) <- liftIO $ runStateT (runStateT (runReaderT (runEventM act) ro) s') stInner --- | 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 - } - deriving ( Functor, Applicative, Monad, MonadIO - , MonadThrow, MonadCatch, MonadMask, MonadFail - ) + EventM $ lift $ lift $ modify $ + \st -> st { nextAction = nextAction stInnerFinal + , esScrollRequests = esScrollRequests stInnerFinal + , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal + , requestedVisibleNames = requestedVisibleNames stInnerFinal + , vtyContext = vtyContext stInnerFinal + } + return (newSt, actResult) -- | The rendering context's current drawing attribute. attrL :: forall r n. Getting r (Context n) Attr diff --git a/src/Brick/Types/EventM.hs b/src/Brick/Types/EventM.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Types/EventM.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Brick.Types.EventM + ( EventM(..) + , getVtyContext + ) +where + +import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif +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 +#if !MIN_VERSION_base(4,13,0) + , MonadFail +#endif + ) + +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) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -45,8 +45,9 @@ , Size(..) , EventState(..) + , VtyContext(..) , EventRO(..) - , Next(..) + , NextAction(..) , Result(..) , Extent(..) , Edges(..) @@ -82,9 +83,9 @@ ) 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,37 +215,47 @@ -- | The type of viewports that indicates the direction(s) in which a -- viewport is scrollable. -data ViewportType = Vertical - -- ^ Viewports of this type are scrollable only vertically. - | Horizontal - -- ^ Viewports of this type are scrollable only horizontally. - | Both - -- ^ Viewports of this type are scrollable vertically and horizontally. - deriving (Show, Eq) +data ViewportType = + Vertical + -- ^ Viewports of this type are scrollable only vertically. + | Horizontal + -- ^ Viewports of this type are scrollable only horizontally. + | Both + -- ^ Viewports of this type are scrollable vertically and horizontally. + deriving (Show, Eq) data CacheInvalidateRequest n = InvalidateSingle n | 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 @@ -- 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 @@ -- 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 @@ deriving (Show, Eq, Ord) data EventRO n = EventRO { eventViewportMap :: M.Map n Viewport - , eventVtyHandle :: Vty , latestExtents :: [Extent n] , oldState :: RenderState n } diff --git a/src/Brick/Widgets/Border.hs b/src/Brick/Widgets/Border.hs --- a/src/Brick/Widgets/Border.hs +++ b/src/Brick/Widgets/Border.hs @@ -39,7 +39,7 @@ -- | The top-level border attribute name. borderAttr :: AttrName -borderAttr = "border" +borderAttr = attrName "border" -- | Draw the specified border element using the active border style -- using 'borderAttr'. diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -22,6 +22,7 @@ , hyperlink -- * Padding + , Padding(..) , padLeft , padRight , padTop @@ -121,10 +122,8 @@ 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 @@ 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. @@ -863,13 +868,14 @@ render $ cropToContext p -- | When drawing the specified widget, set the attribute used for --- drawing to the one with the specified name. Note that the widget --- may use further calls to 'withAttr' to change the active drawing --- attribute, so this only takes effect if nothing in the specified --- widget invokes 'withAttr'. If you want to prevent that, use --- 'forceAttr'. Attributes used this way still get merged hierarchically --- and still fall back to the attribute map's default attribute. If you --- want to change the default attribute, use 'withDefAttr'. +-- drawing to the one with the specified name. Note that the widget may +-- make further changes to the active drawing attribute, so this only +-- takes effect if nothing in the specified widget invokes 'withAttr' +-- or otherwise changes the rendering context's attribute setup. If you +-- want to prevent that, use 'forceAttr'. Attributes used this way still +-- get merged hierarchically and still fall back to the attribute map's +-- default attribute. If you want to change the default attribute, use +-- 'withDefAttr'. -- -- For example: -- @@ -1539,17 +1545,17 @@ -- | The base attribute for scroll bars. scrollbarAttr :: AttrName -scrollbarAttr = "scrollbar" +scrollbarAttr = attrName "scrollbar" -- | The attribute for scroll bar troughs. This attribute is a -- specialization of @scrollbarAttr@. scrollbarTroughAttr :: AttrName -scrollbarTroughAttr = scrollbarAttr <> "trough" +scrollbarTroughAttr = scrollbarAttr <> attrName "trough" -- | The attribute for scroll bar handles. This attribute is a -- specialization of @scrollbarAttr@. scrollbarHandleAttr :: AttrName -scrollbarHandleAttr = scrollbarAttr <> "handle" +scrollbarHandleAttr = scrollbarAttr <> attrName "handle" maybeClick :: (Ord n) => n diff --git a/src/Brick/Widgets/Dialog.hs b/src/Brick/Widgets/Dialog.hs --- a/src/Brick/Widgets/Dialog.hs +++ b/src/Brick/Widgets/Dialog.hs @@ -72,9 +72,9 @@ 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 @@ -99,15 +99,15 @@ -- | The default attribute of the dialog dialogAttr :: AttrName -dialogAttr = "dialog" +dialogAttr = attrName "dialog" -- | The default attribute for all dialog buttons buttonAttr :: AttrName -buttonAttr = "button" +buttonAttr = attrName "button" -- | The attribute for the selected dialog button (extends 'dialogAttr') buttonSelectedAttr :: AttrName -buttonSelectedAttr = buttonAttr <> "selected" +buttonSelectedAttr = buttonAttr <> attrName "selected" -- | Render a dialog with the specified body widget. This renders the -- dialog as a layer, which makes this suitable as a top-level layer in diff --git a/src/Brick/Widgets/Edit.hs b/src/Brick/Widgets/Edit.hs --- a/src/Brick/Widgets/Edit.hs +++ b/src/Brick/Widgets/Edit.hs @@ -62,6 +62,7 @@ -- | Editor state. Editors support the following events by default: -- +-- * Mouse clicks: change cursor position -- * Meta-<: go to beginning of file -- * Meta->: go to end of file -- * Ctrl-a, Home: go to beginning of line @@ -118,11 +119,10 @@ 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 -> @@ -156,6 +156,7 @@ EvKey (KChar '<') [MMeta] -> Z.gotoBOF EvKey (KChar '>') [MMeta] -> Z.gotoEOF _ -> id + put $ applyEdit f ed -- | Construct an editor over 'Text' values editorText :: n @@ -192,12 +193,12 @@ -- | The attribute assigned to the editor when it does not have focus. editAttr :: AttrName -editAttr = "edit" +editAttr = attrName "edit" -- | The attribute assigned to the editor when it has focus. Extends -- 'editAttr'. editFocusedAttr :: AttrName -editFocusedAttr = editAttr <> "focused" +editFocusedAttr = editAttr <> attrName "focused" -- | Get the contents of the editor. getEditContents :: Monoid t => Editor t n -> [t] diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs --- a/src/Brick/Widgets/FileBrowser.hs +++ b/src/Brick/Widgets/FileBrowser.hs @@ -155,6 +155,7 @@ 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 @@ -164,7 +165,7 @@ import Text.Printf (printf) import Brick.Types -import Brick.AttrMap (AttrName) +import Brick.AttrMap (AttrName, attrName) import Brick.Widgets.Core import Brick.Widgets.List @@ -356,10 +357,10 @@ Left (_::E.IOException) -> entries Right parent -> parent : entries - let b' = setEntries allEntries b - return $ b' & fileBrowserWorkingDirectoryL .~ path - & fileBrowserExceptionL .~ exc - & fileBrowserSelectedFilesL .~ mempty + return $ (setEntries allEntries b) + & fileBrowserWorkingDirectoryL .~ path + & fileBrowserExceptionL .~ exc + & fileBrowserSelectedFilesL .~ mempty parentOf :: FilePath -> IO FileInfo parentOf path = getFileInfo ".." $ FP.takeDirectory path @@ -593,126 +594,120 @@ -- * @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 @@ -- 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 @@ -840,49 +837,49 @@ -- | The base attribute for all file browser attributes. fileBrowserAttr :: AttrName -fileBrowserAttr = "fileBrowser" +fileBrowserAttr = attrName "fileBrowser" -- | The attribute used for the current directory displayed at the top -- of the browser. fileBrowserCurrentDirectoryAttr :: AttrName -fileBrowserCurrentDirectoryAttr = fileBrowserAttr <> "currentDirectory" +fileBrowserCurrentDirectoryAttr = fileBrowserAttr <> attrName "currentDirectory" -- | The attribute used for the entry information displayed at the -- bottom of the browser. fileBrowserSelectionInfoAttr :: AttrName -fileBrowserSelectionInfoAttr = fileBrowserAttr <> "selectionInfo" +fileBrowserSelectionInfoAttr = fileBrowserAttr <> attrName "selectionInfo" -- | The attribute used to render directory entries. fileBrowserDirectoryAttr :: AttrName -fileBrowserDirectoryAttr = fileBrowserAttr <> "directory" +fileBrowserDirectoryAttr = fileBrowserAttr <> attrName "directory" -- | The attribute used to render block device entries. fileBrowserBlockDeviceAttr :: AttrName -fileBrowserBlockDeviceAttr = fileBrowserAttr <> "block" +fileBrowserBlockDeviceAttr = fileBrowserAttr <> attrName "block" -- | The attribute used to render regular file entries. fileBrowserRegularFileAttr :: AttrName -fileBrowserRegularFileAttr = fileBrowserAttr <> "regular" +fileBrowserRegularFileAttr = fileBrowserAttr <> attrName "regular" -- | The attribute used to render character device entries. fileBrowserCharacterDeviceAttr :: AttrName -fileBrowserCharacterDeviceAttr = fileBrowserAttr <> "char" +fileBrowserCharacterDeviceAttr = fileBrowserAttr <> attrName "char" -- | The attribute used to render named pipe entries. fileBrowserNamedPipeAttr :: AttrName -fileBrowserNamedPipeAttr = fileBrowserAttr <> "pipe" +fileBrowserNamedPipeAttr = fileBrowserAttr <> attrName "pipe" -- | The attribute used to render symbolic link entries. fileBrowserSymbolicLinkAttr :: AttrName -fileBrowserSymbolicLinkAttr = fileBrowserAttr <> "symlink" +fileBrowserSymbolicLinkAttr = fileBrowserAttr <> attrName "symlink" -- | The attribute used to render Unix socket entries. fileBrowserUnixSocketAttr :: AttrName -fileBrowserUnixSocketAttr = fileBrowserAttr <> "unixSocket" +fileBrowserUnixSocketAttr = fileBrowserAttr <> attrName "unixSocket" -- | The attribute used for selected entries in the file browser. fileBrowserSelectedAttr :: AttrName -fileBrowserSelectedAttr = fileBrowserAttr <> "selected" +fileBrowserSelectedAttr = fileBrowserAttr <> attrName "selected" -- | A file type filter for use with 'setFileBrowserEntryFilter'. This -- filter permits entries whose file types are in the specified list. diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -10,9 +10,8 @@ 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 diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -37,6 +37,7 @@ , listSelectedL , listNameL , listItemHeightL + , listSelectedElementL -- * Accessors , listElements @@ -79,9 +80,9 @@ 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 @@ -- * 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 @@ -- * 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) @@ -251,17 +250,17 @@ -- | The top-level attribute used for the entire list. listAttr :: AttrName -listAttr = "list" +listAttr = attrName "list" -- | The attribute used only for the currently-selected list item when -- the list does not have focus. Extends 'listAttr'. listSelectedAttr :: AttrName -listSelectedAttr = listAttr <> "selected" +listSelectedAttr = listAttr <> attrName "selected" -- | The attribute used only for the currently-selected list item when -- the list has focus. Extends 'listSelectedAttr'. listSelectedFocusedAttr :: AttrName -listSelectedFocusedAttr = listSelectedAttr <> "focused" +listSelectedFocusedAttr = listSelectedAttr <> attrName "focused" -- | Construct a list in terms of container 't' with element type 'e'. list :: (Foldable t) @@ -474,8 +473,7 @@ -- | 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 @@ -- | 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 @@ 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 @@ -- 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 @@ -- -- 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 diff --git a/src/Brick/Widgets/ProgressBar.hs b/src/Brick/Widgets/ProgressBar.hs --- a/src/Brick/Widgets/ProgressBar.hs +++ b/src/Brick/Widgets/ProgressBar.hs @@ -22,11 +22,11 @@ -- | The attribute of the completed portion of the progress bar. progressCompleteAttr :: AttrName -progressCompleteAttr = "progressComplete" +progressCompleteAttr = attrName "progressComplete" -- | The attribute of the incomplete portion of the progress bar. progressIncompleteAttr :: AttrName -progressIncompleteAttr = "progressIncomplete" +progressIncompleteAttr = attrName "progressIncomplete" -- | Draw a progress bar with the specified (optional) label and -- progress value. This fills available horizontal space and is one row diff --git a/tests/List.hs b/tests/List.hs --- a/tests/List.hs +++ b/tests/List.hs @@ -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 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 @@ -29,57 +31,56 @@ import Brick.Widgets.List instance (Arbitrary n, Arbitrary a) => Arbitrary (List n a) where - arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1 - + arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1 -- List move operations that never modify the underlying list -data ListMoveOp a - = MoveUp - | MoveDown - | MoveBy Int - | MoveTo Int - | MoveToElement a - | FindElement a - deriving (Show) +data ListMoveOp a = + MoveUp + | MoveDown + | MoveBy Int + | MoveTo Int + | MoveToElement a + | FindElement a + deriving (Show) instance Arbitrary a => Arbitrary (ListMoveOp a) where - arbitrary = oneof - [ pure MoveUp - , pure MoveDown - , MoveBy <$> arbitrary - , MoveTo <$> arbitrary - , MoveToElement <$> arbitrary - , FindElement <$> arbitrary - ] + arbitrary = + oneof [ pure MoveUp + , pure MoveDown + , MoveBy <$> arbitrary + , MoveTo <$> arbitrary + , MoveToElement <$> arbitrary + , FindElement <$> arbitrary + ] -- List operations. We don't have "page"-based movement operations -- because these depend on render context (i.e. effect in EventM) -data ListOp a - = Insert Int a - | Remove Int - | Replace Int [a] - | Clear - | Reverse - | ListMoveOp (ListMoveOp a) - deriving (Show) +data ListOp a = + Insert Int a + | Remove Int + | Replace Int [a] + | Clear + | Reverse + | ListMoveOp (ListMoveOp a) + deriving (Show) instance Arbitrary a => Arbitrary (ListOp a) where - arbitrary = frequency - [ (1, Insert <$> arbitrary <*> arbitrary) - , (1, Remove <$> arbitrary) - , (1, Replace <$> arbitrary <*> arbitrary) - , (1, pure Clear) - , (1, pure Reverse) - , (6, arbitrary) - ] + arbitrary = + frequency [ (1, Insert <$> arbitrary <*> arbitrary) + , (1, Remove <$> arbitrary) + , (1, Replace <$> arbitrary <*> arbitrary) + , (1, pure Clear) + , (1, pure Reverse) + , (6, arbitrary) + ] -- Turn a ListOp into a List endomorphism op :: Eq a => ListOp a -> List n a -> List n a op (Insert i a) = listInsert i a op (Remove i) = listRemove i op (Replace i xs) = - -- avoid setting index to Nothing - listReplace (V.fromList xs) (Just i) + -- avoid setting index to Nothing + listReplace (V.fromList xs) (Just i) op Clear = listClear op Reverse = listReverse op (ListMoveOp mo) = moveOp mo @@ -93,63 +94,61 @@ moveOp (MoveToElement a) = listMoveToElement a moveOp (FindElement a) = listFindBy (== a) -applyListOps - :: (Foldable t) - => (op a -> List n a -> List n a) -> t (op a) -> List n a -> List n a +applyListOps :: (Foldable t) + => (op a -> List n a -> List n a) + -> t (op a) + -> List n a + -> List n a applyListOps f = appEndo . foldMap (Endo . f) - -- | Initial selection is always 0 (or Nothing for empty list) prop_initialSelection :: [a] -> Bool prop_initialSelection xs = - list () (V.fromList xs) 1 ^. listSelectedL == - if null xs then Nothing else Just 0 + list () (V.fromList xs) 1 ^. listSelectedL == + if null xs then Nothing else Just 0 -- list operations keep the selected index in bounds -prop_listOpsMaintainSelectedValid - :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_listOpsMaintainSelectedValid :: (Eq a) + => [ListOp a] + -> List n a + -> Bool prop_listOpsMaintainSelectedValid ops l = - let l' = applyListOps op ops l - in - case l' ^. listSelectedL of - -- either there is no selection and list is empty - Nothing -> null l' - -- or the selected index is valid - Just i -> i >= 0 && i < length l' + let l' = applyListOps op ops l + in case l' ^. listSelectedL of + -- either there is no selection and list is empty + Nothing -> null l' + -- or the selected index is valid + Just i -> i >= 0 && i < length l' -- reversing a list keeps the selected element the same -prop_reverseMaintainsSelectedElement - :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_reverseMaintainsSelectedElement :: (Eq a) + => [ListOp a] + -> List n a + -> Bool prop_reverseMaintainsSelectedElement ops l = - let -- apply some random list ops to (probably) set a selected element - l' = applyListOps op ops l - l'' = listReverse l' - in - fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'') + let l' = applyListOps op ops l + l'' = listReverse l' + in fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'') -- reversing maintains size of list prop_reverseMaintainsSizeOfList :: List n a -> Bool prop_reverseMaintainsSizeOfList l = - length l == length (listReverse l) + length l == length (listReverse l) -- an inserted element may always be found at the given index -- (when target index is clamped to 0 <= n <= len) prop_insert :: (Eq a) => Int -> a -> List n a -> Bool prop_insert i a l = - let - l' = listInsert i a l - i' = clamp 0 (length l) i - in - listSelectedElement (listMoveTo i' l') == Just (i', a) + let l' = listInsert i a l + i' = clamp 0 (length l) i + in listSelectedElement (listMoveTo i' l') == Just (i', a) -- inserting anywhere always increases size of list by 1 prop_insertSize :: (Eq a) => Int -> a -> List n a -> Bool prop_insertSize i a l = - let - l' = listInsert i a l - in - length l' == length l + 1 + let l' = listInsert i a l + in length l' == length l + 1 -- inserting an element and moving to it always succeeds and -- the selected element is the one we inserted. @@ -160,11 +159,9 @@ -- prop_insertMoveTo :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool prop_insertMoveTo ops l i a = - let - l' = listInsert i a (applyListOps op ops l) - sel = listSelectedElement (listMoveToElement a l') - in - fmap snd sel == Just a + let l' = listInsert i a (applyListOps op ops l) + sel = listSelectedElement (listMoveToElement a l') + in fmap snd sel == Just a -- inserting an element and repeatedly seeking it always -- reaches the element we inserted, at the index where we @@ -172,47 +169,38 @@ -- prop_insertFindBy :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool prop_insertFindBy ops l i a = - let - l' = applyListOps op ops l - l'' = set listSelectedL Nothing . listInsert i a $ l' - seeks = converging ((==) `on` (^. listSelectedL)) (listFindBy (== a)) l'' - i' = clamp 0 (length l') i -- we can't have inserted past len - in - (find ((== Just i') . (^. listSelectedL)) seeks >>= listSelectedElement) - == Just (i', a) + let l' = applyListOps op ops l + l'' = set listSelectedL Nothing . listInsert i a $ l' + seeks = converging ((==) `on` (^. listSelectedL)) (listFindBy (== a)) l'' + i' = clamp 0 (length l') i -- we can't have inserted past len + in (find ((== Just i') . (^. listSelectedL)) seeks >>= listSelectedElement) == Just (i', a) -- inserting then deleting always yields a list with the original elems prop_insertRemove :: (Eq a) => Int -> a -> List n a -> Bool prop_insertRemove i a l = - let - i' = clamp 0 (length l) i - l' = listInsert i' a l -- pre-clamped - l'' = listRemove i' l' - in - l'' ^. listElementsL == l ^. listElementsL + let i' = clamp 0 (length l) i + l' = listInsert i' a l -- pre-clamped + l'' = listRemove i' l' + in l'' ^. listElementsL == l ^. listElementsL -- deleting in-bounds always reduces size of list by 1 -- deleting out-of-bounds never changes list size prop_remove :: Int -> List n a -> Bool prop_remove i l = - let - len = length l - i' = clamp 0 (len - 1) i - test - | len > 0 && i == i' = (== len - 1) -- i is in bounds - | otherwise = (== len) -- i is out of bounds - in - test (length (listRemove i l)) + let len = length l + i' = clamp 0 (len - 1) i + test + | len > 0 && i == i' = (== len - 1) -- i is in bounds + | otherwise = (== len) -- i is out of bounds + in test (length (listRemove i l)) -- deleting an element and re-inserting it at same position -- gives the original list elements prop_removeInsert :: (Eq a) => Int -> List n a -> Bool prop_removeInsert i l = - let - sel = listSelectedElement (listMoveTo i l) - l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l - in - l' ^. listElementsL == l ^. listElementsL + let sel = listSelectedElement (listMoveTo i l) + l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l + in l' ^. listElementsL == l ^. listElementsL -- Apply @f@ until @test a (f a) == True@, then return @a@. converge :: (a -> a -> Bool) -> (a -> a) -> a -> a @@ -222,64 +210,57 @@ -- intermediate and final values as a list. converging :: (a -> a -> Bool) -> (a -> a) -> a -> [a] converging test f a - | test a (f a) = [a] - | otherwise = a : converging test f (f a) + | test a (f a) = [a] + | otherwise = a : converging test f (f a) -- listMoveUp always reaches 0 (or list is empty) prop_moveUp :: (Eq a) => [ListOp a] -> List n a -> Bool prop_moveUp ops l = - let - l' = applyListOps op ops l - l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l' - len = length l'' - in - maybe (len == 0) (== 0) (l'' ^. listSelectedL) + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l' + len = length l'' + in maybe (len == 0) (== 0) (l'' ^. listSelectedL) -- listMoveDown always reaches end of list (or list is empty) prop_moveDown :: (Eq a) => [ListOp a] -> List n a -> Bool prop_moveDown ops l = - let - l' = applyListOps op ops l - l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l' - len = length l'' - in - maybe (len == 0) (== len - 1) (l'' ^. listSelectedL) + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l' + len = length l'' + in maybe (len == 0) (== len - 1) (l'' ^. listSelectedL) -- move ops never change the list prop_moveOpsNeverChangeList :: (Eq a) => [ListMoveOp a] -> List n a -> Bool prop_moveOpsNeverChangeList ops l = - let - l' = applyListOps moveOp ops l - in - l' ^. listElementsL == l ^. listElementsL + let l' = applyListOps moveOp ops l + in l' ^. listElementsL == l ^. listElementsL -- If the list is empty, empty selection is used. -- Otherwise, if the specified selected index is not in list bounds, -- zero is used instead. -prop_replaceSetIndex - :: (Eq a) - => [ListOp a] -> List n a -> [a] -> Int -> Bool +prop_replaceSetIndex :: (Eq a) + => [ListOp a] + -> List n a + -> [a] + -> Int + -> Bool prop_replaceSetIndex ops l xs i = - let - v = V.fromList xs - l' = applyListOps op ops l - l'' = listReplace v (Just i) l' - i' = clamp 0 (length v - 1) i - inBounds = i == i' - in - l'' ^. listSelectedL == case (null v, inBounds) of - (True, _) -> Nothing - (False, True) -> Just i - (False, False) -> Just 0 + let v = V.fromList xs + l' = applyListOps op ops l + l'' = listReplace v (Just i) l' + i' = clamp 0 (length v - 1) i + inBounds = i == i' + in l'' ^. listSelectedL == case (null v, inBounds) of + (True, _) -> Nothing + (False, True) -> Just i + (False, False) -> Just 0 -- Replacing with no index always clears the index prop_replaceNoIndex :: (Eq a) => [ListOp a] -> List n a -> [a] -> Bool prop_replaceNoIndex ops l xs = - let - v = V.fromList xs - l' = applyListOps op ops l - in - isNothing (listReplace v Nothing l' ^. listSelectedL) + let v = V.fromList xs + l' = applyListOps op ops l + in isNothing (listReplace v Nothing l' ^. listSelectedL) -- | Move the list selected index. If the index is `Just x`, adjust by the -- specified amount; if it is `Nothing` (i.e. there is no selection) and the @@ -287,26 +268,19 @@ -- `Just (length - 1)` (last element). Subject to validation. prop_moveByWhenNoSelection :: List n a -> Int -> Property prop_moveByWhenNoSelection l amt = - let - l' = l & listSelectedL .~ Nothing - len = length l - expected = if amt > 0 then 0 else len - 1 - in - len > 0 ==> listMoveBy amt l' ^. listSelectedL == Just expected - + let l' = l & listSelectedL .~ Nothing + len = length l + expected = if amt > 0 then 0 else len - 1 + in len > 0 ==> listMoveBy amt l' ^. listSelectedL == Just expected splitAtLength :: (Foldable t, Splittable t) => t a -> Int -> Bool splitAtLength l i = - let - len = length l - (h, t) = splitAt i l - in - length h + length t == len - && length h == clamp 0 len i + let len = length l + (h, t) = splitAt i l + in length h + length t == len && length h == clamp 0 len i -splitAtAppend - :: (Splittable t, Semigroup (t a), Eq (t a)) - => t a -> Int -> Bool +splitAtAppend :: (Splittable t, Semigroup (t a), Eq (t a)) + => t a -> Int -> Bool splitAtAppend l i = uncurry (<>) (splitAt i l) == l prop_splitAtLength_Vector :: [a] -> Int -> Bool @@ -322,16 +296,14 @@ prop_splitAtAppend_Seq = splitAtAppend . Seq.fromList -reverseSingleton - :: forall t a. (Reversible t, Applicative t, Eq (t a)) - => Proxy t -> a -> Bool +reverseSingleton :: forall t a. (Reversible t, Applicative t, Eq (t a)) + => Proxy t -> a -> Bool reverseSingleton _ a = - let l = pure a :: t a - in reverse l == l + let l = pure a :: t a + in reverse l == l -reverseAppend - :: (Reversible t, Semigroup (t a), Eq (t a)) - => t a -> t a -> Bool +reverseAppend :: (Reversible t, Semigroup (t a), Eq (t a)) + => t a -> t a -> Bool reverseAppend l1 l2 = reverse (l1 <> l2) == reverse l2 <> reverse l1 @@ -340,49 +312,54 @@ prop_reverseAppend_Vector :: (Eq a) => [a] -> [a] -> Bool prop_reverseAppend_Vector l1 l2 = - reverseAppend (V.fromList l1) (V.fromList l2) + reverseAppend (V.fromList l1) (V.fromList l2) prop_reverseSingleton_Seq :: (Eq a) => a -> Bool prop_reverseSingleton_Seq = reverseSingleton (Proxy :: Proxy Seq.Seq) prop_reverseAppend_Seq :: (Eq a) => [a] -> [a] -> Bool prop_reverseAppend_Seq l1 l2 = - reverseAppend (Seq.fromList l1) (Seq.fromList l2) - - + reverseAppend (Seq.fromList l1) (Seq.fromList l2) -- Laziness tests. Here we create a custom container type -- that we use to ensure certain operations do not cause the -- whole container to be evaluated. -- newtype L a = L [a] - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable, Semigroup) instance Splittable L where - splitAt i (L xs) = over both L (Data.List.splitAt i xs) + splitAt i (L xs) = over both L (Data.List.splitAt i xs) -- moveBy positive amount does not evaluate 'length' prop_moveByPosLazy :: Bool prop_moveByPosLazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 - l' = listMoveBy 1 l - in - l' ^. listSelectedL == Just 1 + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 + l' = listMoveBy 1 l + in l' ^. listSelectedL == Just 1 -- listFindBy is lazy prop_findByLazy :: Bool prop_findByLazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 & listSelectedL .~ Nothing - l' = listFindBy even l - l'' = listFindBy even l' - in - l' ^. listSelectedL == Just 1 - && l'' ^. listSelectedL == Just 3 + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Nothing + l' = listFindBy even l + l'' = listFindBy even l' + in l' ^. listSelectedL == Just 1 && + l'' ^. listSelectedL == Just 3 +prop_listSelectedElement_lazy :: Bool +prop_listSelectedElement_lazy = + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Just 3 + in listSelectedElement l == Just (3, 4) + +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 []