brick 1.3 → 3.0
raw patch · 80 files changed
Files
- CHANGELOG.md +449/−2
- LICENSE +1/−1
- README.md +91/−57
- brick.cabal +138/−93
- docs/guide.rst +40/−19
- docs/programs-screenshots.md +0/−70
- docs/programs-screenshots/brick-attr-demo.png binary
- docs/programs-screenshots/brick-border-demo.png binary
- docs/programs-screenshots/brick-cache-demo.png binary
- docs/programs-screenshots/brick-custom-event-demo.png binary
- docs/programs-screenshots/brick-dialog-demo.png binary
- docs/programs-screenshots/brick-dynamic-border-demo.png binary
- docs/programs-screenshots/brick-edit-demo.png binary
- docs/programs-screenshots/brick-file-browser-demo.png binary
- docs/programs-screenshots/brick-fill-demo.png binary
- docs/programs-screenshots/brick-form-demo.png binary
- docs/programs-screenshots/brick-hello-world-demo.png binary
- docs/programs-screenshots/brick-layer-demo.png binary
- docs/programs-screenshots/brick-list-demo.png binary
- docs/programs-screenshots/brick-list-vi-demo.png binary
- docs/programs-screenshots/brick-mouse-demo.png binary
- docs/programs-screenshots/brick-padding-demo.png binary
- docs/programs-screenshots/brick-progressbar-demo.png binary
- docs/programs-screenshots/brick-readme-demo.png binary
- docs/programs-screenshots/brick-suspend-resume-demo.png binary
- docs/programs-screenshots/brick-text-wrap-demo.png binary
- docs/programs-screenshots/brick-theme-demo.png binary
- docs/programs-screenshots/brick-viewport-scroll-demo.png binary
- docs/programs-screenshots/brick-visibility-demo.png binary
- programs/AnimationDemo.hs +223/−0
- programs/BorderDemo.hs +18/−13
- programs/CustomEventDemo.hs +3/−4
- programs/DialogDemo.hs +14/−8
- programs/EditorLineNumbersDemo.hs +135/−0
- programs/FormDemo.hs +4/−2
- programs/LayerDemo.hs +27/−15
- programs/ListDemo.hs +18/−11
- programs/MenuBarDemo.hs +146/−0
- programs/MenuDemo.hs +129/−0
- programs/MenuKeybindingsDemo.hs +177/−0
- programs/MouseDemo.hs +11/−7
- programs/ProgressBarDemo.hs +48/−4
- programs/TabularListDemo.hs +146/−0
- programs/TailDemo.hs +2/−3
- programs/ThemeDemo.hs +1/−1
- programs/ViewportScrollbarsDemo.hs +71/−17
- src/Brick.hs +1/−1
- src/Brick/Animation.hs +588/−0
- src/Brick/Animation/Clock.hs +64/−0
- src/Brick/AttrMap.hs +18/−0
- src/Brick/BorderMap.hs +2/−0
- src/Brick/Focus.hs +1/−0
- src/Brick/Forms.hs +126/−17
- src/Brick/Keybindings/KeyConfig.hs +15/−6
- src/Brick/Keybindings/KeyDispatcher.hs +17/−3
- src/Brick/Keybindings/Normalize.hs +14/−0
- src/Brick/Keybindings/Parse.hs +3/−2
- src/Brick/Keybindings/Pretty.hs +7/−8
- src/Brick/Main.hs +73/−16
- src/Brick/Themes.hs +0/−2
- src/Brick/Types.hs +3/−9
- src/Brick/Types/Common.hs +10/−5
- src/Brick/Types/Internal.hs +206/−77
- src/Brick/Util.hs +8/−6
- src/Brick/Widgets/Border.hs +21/−4
- src/Brick/Widgets/Center.hs +19/−28
- src/Brick/Widgets/Core.hs +514/−266
- src/Brick/Widgets/Dialog.hs +73/−61
- src/Brick/Widgets/Edit.hs +4/−4
- src/Brick/Widgets/FileBrowser.hs +74/−36
- src/Brick/Widgets/Internal.hs +126/−39
- src/Brick/Widgets/List.hs +81/−35
- src/Brick/Widgets/Menu.hs +1015/−0
- src/Brick/Widgets/MenuBar.hs +280/−0
- src/Brick/Widgets/ProgressBar.hs +30/−4
- src/Brick/Widgets/Table.hs +130/−72
- src/Data/IMap.hs +3/−0
- tests/List.hs +23/−0
- tests/Main.hs +6/−2
- tests/Render.hs +2/−1
CHANGELOG.md view
@@ -2,6 +2,453 @@ Brick changelog --------------- +3.0+---++This release focuses on two major new features that include some+breaking API changes: *layer embedding* and *pop-up menus*.++* Layer embedding: This release introduces a powerful new function,+ `Brick.Widgets.Core.above`, written ``a `above` b`` that allows any+ widget at any layer (in this case, `b`) to introduce a new layer+ floating above it (here, `a`), positioned relative to the upper-left+ corner of the lower element. This makes the introduction of floating+ layers much more modular and composable. This change brings with it+ some API and behavioral changes; see below for details. Prior to the+ addition of this feature, the only way to introduce new layers into+ Brick's output was to include them in the list of layers returned by+ the top-level application draw function. This made it difficult to use+ layers in a modular way as part of UI components because the top-level+ draw function would need to be updated to introduce any layers+ needed by elements in the UI. The `LayerDemo` (`brick-layer-demo`)+ demonstration program was updated to include a demonstration of+ `above`.+* Pop-up menus: taking advantage of the new `above` function are the new+ modules `Brick.Widgets.Menu` and `Brick.Widgets.MenuBar`, which+ introduce support for menus and menu bars in Brick applications. The+ menu interface allows for custom menus as well as menus that integrate+ with Brick's custom keybinding infrastructure. To learn more, see+ the Haddock documentation for those modules as well as the new+ demonstration programs, built with `cabal run -f demos <progname>`:+ * `programs/MenuDemo.hs` (`brick-menu-demo`)+ * `programs/MenuKeybindingsDemo.hs` (`brick-menu-keybindings-demo`)+ * `programs/MenuBarDemo.hs` (`brick-menu-bar-demo`)++Additional layer embedding details:++The layer embedding feature comes with a rework of how Brick handles+layer translations. Here's a summary of the impact:++* `translateBy` was renamed to `translateLayer` and now has no effect on+ non-layer widgets. Previously, `translateBy` worked by adding left and+ top padding for positive translations, and by performing cropping for+ negative translations. While this gave the desired effect, it wasn't+ a true translation and it needed to be changed to support the new+ layer embedding feature. Starting with this release, `translateLayer`+ does a true translation without modifying the layer image itself. When+ applied to a non-layer, it has no effect. A widget is a non-layer if+ it gets embedded within or modified by another widget (such as by+ embedding it in an `hBox`).+* `relativeTo` was renamed to `layerRelativeTo` to clarify that its+ use is only for layers; like `translateLayer`, it has no effect for+ non-layer widgets. Its behavior is unchanged.+* Applications that were exploiting the previous padding and cropping+ behavior of `translateBy` for non-layer widgets should migrate to+ applying padding and cropping directly to achieve the same result.+ Most applications can likely just update to account for the renamings+ without further changes.+* `above` also works in viewports and behaves as one might expect:+ layers above viewport content are placed as specified, but are cropped+ as they are scrolled out of view.+* The layer-handling functions in `Brick.Widgets.Center` were updated to+ use `translateLayer`. Their apparent behavior is unchanged.+* Widget-modifying functions are commutative with `translateLayer`. In+ general, any transformation applied to a layer is applied directly+ to the layer itself without regard for its translation position. For+ example, these are equivalent:+ * `padLeft (Pad 2) $ translateLayer (Location (a, b)) $ txt "foo"`+ * `translateLayer (Location (a, b)) $ padLeft (Pad 2) $ txt "foo"`+* Cropping functions were changed to use less aggressive context sizes.+ Prior to this change, cropping functions rendered with a rendering+ context using the size of the widget being cropped as the basis for+ the cropping amount. This turned out to be too aggressive when things+ like cursor positions and other positional information were present+ outside the widgets' cropped regions, since they could be mistakenly+ removed from the rendering result. For example, `cropLeftBy 1 (str+ "foo")` previously would crop to "oo" and remove any extents and+ cursor positions to the *right* of the "oo" portion of the result even+ though that area shouldn't be affected at all because it wasn't in the+ cropped portion of the image. The improvement to these functions fixes+ this behavior so that only cursors, extents, etc. in the affected+ image region are cropped.++Other improvements in this release:++* Mouse clicks in layers will no longer fall through to lower layers+ when the mouse clicks occur at locations that aren't within any named+ regions in the clicked layer. Prior to this change, Brick would+ report click events in clickable regions even if those clickable+ regions were obscured by higher, non-clickable layers. This obviously+ isn't good and is almost certainly never what anyone wants; the+ more natural behavior is to ensure that a clickable region is+ only clickable if it is not obscured by anything on top of it.+ `Brick.Main.findClickedExtents` now reflects this behavior, which+ means that the function no longer reports underlying region matches if+ they are obscured.++API changes in this release:++* Added new modules:+ * `Brick.Widgets.Menu`+ * `Brick.Widgets.MenuBar`+* `Brick.Widgets.Core`:+ * Added `clampLayerToScreen`+ * Added `char` `Widget` constructor+ * Renamed `translateBy` to `translateLayer`+ * Renamed `relativeTo` to `layerRelativeTo`+* `Brick.Types` now exports `Result` lenses `performTranslationL` and+ `translationOffsetL` used in tracking layer translations.+* `Brick.Keybindings.KeyDispatcher`:+ * Added `bindingsForEvent` for obtaining bindings for an event from a+ dispatcher+ * Added `lookupEvent` for looking up a handler by key event++Functionality-preserving changes:++* Made `Brick.Types.Location` a `newtype`. Previously, `Location` was a+ normal data type with one record field to access its inner tuple; it+ is now a `newtype` wrapper around that tuple with the same record+ field name.++Package changes:++* Set a lower bound on `text` to `2.1.2`++Repository changes:++* Renamed the `master` branch to `main`++2.13+----++New features:++* Brick.Widgets.List: added support for wrapping (thanks Enrico Maria De+ Angelis). The List API now provides `setScrollWrap`, `getScrollWrap`,+ and `listScrollWrapL` to configure lists to wrap when moving their+ cursor, and the cursor-movement functions and event handlers now cause+ selection wrapping when a list has wrapping enabled. The `ListDemo`+ demo program was also updated to demonstrate the wrapping behavior.++2.12+----++Package changes:++* Raised upper bound on microlens to allow building with 0.5.++2.11+----++Bug fixes:++* Fixed a bug in FileBrowser: if a user pressed Enter when the cursor+ was on a selected entry, it was omitted from the list of+ selected browser entries. As part of this change, the function+ `actionFileBrowserSelectCurrent` previously toggled the selection+ of the entry at the cursor, but should have selected it instead.+ It now does so, and a new function for toggling was introduced:+ `actionFileBrowserToggleCurrent`.++Other changes:++* Upper bounds on `base` and `microlens` were adjusted.++2.10+----++* Updated `brick` to build with `microlens == 0.5.0.0` which moved its+ Field* classes to `Lens.Micro.FieldN`.++2.9+---++API changes:+* Added `Brick.Widgets.List.listFindFirst` function.++2.8.3+-----++Bug fixes:++* Fixed a bug that completely broke `makeVisible` that was introduced+ in brick 2.6.+* Fixed context cropping in `cropRightBy` and `cropBottomBy`.++2.8.2+-----++* Updated `Brick.Widgets.Core` functions `cropBottomBy`, `cropToBy`,+ `cropLeftBy`, and `cropRightBy` to properly perform result cropping to+ actually address the internal bug fixed in 2.8.1.++2.8.1+-----++* Fixed a long-standing bug in `cropToContext` that resulted in some+ extents getting left around when they should be dropped, possibly+ leading to application bugs when handling mouse clicks in extent+ regions that should have been removed from the rendering result.++2.8+---++Behavior changes:+* `FileBrowser` file marking with `Space` now honors the file browser's+ configured file selector predicate.+* `FileBrowser` file marking with `Space` and `Enter` now toggles file+ selection rather than just selecting files, allowing for selected+ files to be unselected.++2.7+---++This release adds `Brick.Animation`, a module providing infrastructure+for adding animations to Brick interfaces. See the Haddock documentation+in `Brick.Animation` for full details; see `programs/AnimationDemo.hs`+for a working example.++2.6+---++Behavior changes:+ * `Brick.Widgets.Core.relativeTo` now draws nothing if the requested+ extent is not found. Previously it would draw the specified widget in+ the upper-left corner of the layer.++Bug fixes:+ * Fixed the conditional import in `BorderMap` (#519)+ * `Brick.Widgets.Center.hCenterWith` now properly accounts for centered+ image width when computing additional right padding (#520)+ * The Brick renderer now properly resets some render-specific state+ in between renderings that was previously kept around, avoiding+ preservation of stale extents across renderings+ * `brick-tail-demo` and `brick-custom-event-demo` now shut down Vty+ properly++2.5+---++New features:+* `Brick.Widgets.ProgressBar` got a new function, `customProgressBar`,+ which allows the customization of the fill characters used to draw a+ progress bar. (Thanks @sectore)++2.4+---++Changes:+* The `Keybindings` API now normalizes keybindings+ to lowercase when modifiers are present. (See also+ https://github.com/jtdaugherty/brick/issues/512) This means that,+ for example, a constructed binding for `C-X` would be normalized to+ `C-x`, and a binding from a configuration file written `C-X` would be+ parsed and then normalized to `C-x`. This is because, in general, when+ modifiers are present, input events are received for the lowercase+ version of the character in question. Prior to changing this, Brick+ would silently parse (or permit the construction of) uppercase-mapped+ key bindings, but in practice those bindings were unusable because+ they are not generated by terminals.++2.3.2+-----++Bug fixes:+* `FileBrowser`: if the `FileBrowser` was initialized with a `FilePath`+ that ended in a slash, then if the user hit `Enter` on the `../` entry+ to move to the parent directory, the only effect was the removal of+ that trailing slash. This change trims the trailing slash so that the+ expected move occurs whenever the `../` entry is selected.+* `Brick.Keybindings.Pretty.keybindingHelpWidget`: fixed a problem where+ a key event with no name in a `KeyEvents` would cause a `fromJust`+ exception. The pretty-printer now falls back to a placeholder+ representation for such unnamed key events.++2.3.1+-----++Bug fixes:+* Form field rendering now correctly checks for form field focus when+ its visibility mode is `ShowAugmentedField`.++2.3+---++API changes:+* `FormFieldVisibilityMode`'s `ShowAugmentedField` was renamed to+ `ShowCompositeField` to be clearer about what it does, and a new+ `ShowAugmentedField` constructor was added to support a mode where+ field augmentations applied with `@@=` are made visible as well.++2.2+---++Enhancements:+* `Brick.Forms` got a new `FormFieldVisibilityMode` type and a+ `setFieldVisibilityMode` function to allow greater control over+ how form field collections are brought into view when forms are+ rendered in viewports. Form fields will default to using the+ `ShowFocusedFieldOnly` mode which preserves functionality prior to+ this release. To get the new behavior, set a field's visibility mode+ to `ShowAugmentedField`.++2.1.1+-----++Bug fixes:+* `defaultMain` now properly shuts down Vty before it returns, fixing+ a bug where the terminal would be in an unclean state on return from+ `defaultMain`.++2.1+---++API changes:++* Added `Brick.Main.customMainWithDefaultVty` as an alternative way to+ initialize Brick.++2.0+---++This release updates Brick to support Vty 6, which includes support for+Windows.++Package changes:+* Increased lower bound on `vty` to 6.0.+* Added dependency on `vty-crossplatform`.+* Migrated from `unix` dependency to `unix-compat`.++Other changes:+* Update core library and demo programs to use `vty-crossplatform` to+ initialize the terminal.++1.10+----++API changes:+* The `ScrollbarRenderer` type got split up into vertical and horizontal+ versions, `VScrollbarRenderer` and `HScrollbarRenderer`, respectively.+ Their fields are nearly identical to the original `ScrollbarRenderer`+ fields except that many fields now have a `V` or `H` in them as+ appropriate. As part of this change, the various `Brick.Widgets.Core`+ functions that deal with the renderers got their types updated, and+ the types of the default scroll bar renderers changed, too.+* The scroll bar renderers now have a field to control how much space+ is allocated to a scroll bar. Previously, all scroll bars were+ assumed to be exactly one row in height or one column in width. This+ change is motivated by a desire to be able to control how scroll+ bars are rendered adjacent to viewport contents. It isn't always+ desirable to render them right up against the contents; sometimes,+ spacing would be nice between the bar and contents, for example.+ As part of this change, `VScrollbarRenderer` got a field called+ `scrollbarWidthAllocation` and `HScrollbarRenderer` got a field called+ `scrollbarHeightAllocation`. The fields specify the height (for+ horizontal scroll bars) or width (for vertical ones) of the region+ in which the bar is rendered, allowing scroll bar element widgets+ to take up more than one row in height (for horizontal scroll bars)+ or more than one column in width (for vertical ones) as desired. If+ the widgets take up less space, padding is added between the scroll+ bar and the viewport contents to pad the scroll bar to take up the+ specified allocation.++1.9+---++API changes:+* `FocusRing` got a `Show` instance.++1.8+---++API changes:+* Added `Brick.Widgets.Core.forceAttrAllowStyle`, which is like+ `forceAttr` but allows styles to be preserved rather than overridden.++Other improvements:+* The `Brick.Forms` documentation was updated to clarify how attributes+ get used for form fields.++1.7+---++Package changes:+* Allow building with `base` 4.18 (GHC 9.6) (thanks Mario Lang)++API changes:+* Added a new function, `Brick.Util.style`, to create a Vty `Attr` from+ a style value (thanks Amir Dekel)++Other improvements:+* `Brick.Forms.renderForm` now issues a visibility request for the+ focused form field, which makes forms usable within viewports.++1.6+---++Package changes:+* Support `mtl` 2.3 (thanks Daniel Firth)++API changes:+* `Brick.Widgets.Table` got a new `alignColumns` function that can be+ used to do column layout of a list of widgets using `ColumnAlignment`+ values from the table API.+* `Brick.Widgets.Table` got a new low-level table-rendering API for use+ in applications that want to use the table layout machinery without+ using `Table` itself. This includes:+ * `tableCellLayout` - does table cell layout using table configuration+ settings,+ * `addBorders` - adds row, column, and surrounding borders using table+ border-drawing settings, and+ * `RenderedTableCells` and `BorderConfiguration` - the low-level types+ used for the new functions.++Other changes:+* Added a new `EditorLineNumbersDemo` demo program.++1.5+---++This release focuses on API improvements in `Brick.Widgets.Dialog`:++* `Dialog` got an additional type argument, `n`, for resource names.+* The `dialog` constructor now takes `[(String, n, a)]` rather than+ `[(String, a)]`; this allows the caller to associate a resource name+ with each dialog button.+* Dialog buttons now report click events under their associated resource+ names.+* Dialog buttons now `putCursor` when they are focused in order to work+ better with screen readers.+* The `Dialog` module got `getDialogFocus` and `setDialogFocus`+ functions to help with focus management, and as part of this change,+ the `dialogSelectedIndex` function and its lens `dialogSelectedIndexL`+ were removed.++1.4+---++API changes:+* `Brick.Widgets.Border` got `hBorderAttr` and `vBorderAttr` for use by+ `hBorder` and `vBorder` respectively. The new attributes inherit from+ `borderAttr`, so applications that just specify `borderAttr` will not+ see any change in behavior for those specific border elements.++Performance improvements:+* `Brick.Widgets.Core.txt` had its performance improved. (thanks Fraser+ Tweedale)+* `Brick.Widgets.Core.hBox` and `vBox` had their performance improved.+ (thanks Fraser Tweedale)+ 1.3 --- @@ -47,7 +494,7 @@ 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+programs to see working 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). @@ -1563,7 +2010,7 @@ Bug fixes: * Fixed viewport behavior when the image in a viewport reduces its size enough to render the viewport offsets invalid. Before, this behavior- caused a crash during image croppin in vty; now the behavior is+ caused a crash during image cropping in vty; now the behavior is handled sanely (fixes #22; reported by Hans-Peter Deifel) 0.2.2
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015-2018, Jonathan Daugherty.+Copyright (c) 2015-2025, Jonathan Daugherty. All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -6,13 +6,16 @@ you provide a state transformation function to handle events. `brick` exposes a declarative API. Unlike most GUI toolkits which-require you to write a long and tedious sequence of "create a widget,-now bind an event handler", `brick` just requires you to describe your-interface using a set of declarative layout combinators.+require you to write a long and tedious sequence of widget creations+and layout setup, `brick` just requires you to describe your interface+using a set of declarative layout combinators. Event-handling is done by+pattern-matching on incoming events and updating your application state. Under the hood, this library builds upon [vty](http://hackage.haskell.org/package/vty), so some knowledge of Vty-will be helpful in using this library.+will be necessary to use this library. Brick depends on+`vty-crossplatform`, so Brick should work anywhere Vty works (Unix and+Windows). Brick releases prior to 2.0 only support Unix-based systems. Example -------@@ -47,58 +50,69 @@ | Project | Description | | ------- | ----------- |-| [`tetris`](https://github.com/SamTay/tetris) | An implementation of the Tetris game |-| [`gotta-go-fast`](https://github.com/callum-oakley/gotta-go-fast) | A typing tutor |-| [`haskell-player`](https://github.com/potomak/haskell-player) | An `afplay` frontend |-| [`mushu`](https://github.com/elaye/mushu) | An `MPD` client |-| [`matterhorn`](https://github.com/matterhorn-chat/matterhorn) | A client for [Mattermost](https://about.mattermost.com/) |-| [`viewprof`](https://github.com/maoe/viewprof) | A GHC profile viewer |-| [`tart`](https://github.com/jtdaugherty/tart) | A mouse-driven ASCII art drawing program |-| [`silly-joy`](https://github.com/rootmos/silly-joy) | An interpreter for Joy |-| [`herms`](https://github.com/jackkiefer/herms) | A command-line tool for managing kitchen recipes |-| [`purebred`](https://github.com/purebred-mua/purebred) | A mail user agent | | [`2048Haskell`](https://github.com/8Gitbrix/2048Haskell) | An implementation of the 2048 game |+| [`babel-cards`](https://github.com/srhoulam/babel-cards) | A TUI spaced-repetition memorization tool. Similar to Anki. | | [`bhoogle`](https://github.com/andrevdm/bhoogle) | A [Hoogle](https://www.haskell.org/hoogle/) client |+| [`bollama`](https://github.com/andrevdm/bollama) | A simple [Ollama](https://ollama.com/) TUI |+| [`brewsage`](https://github.com/gerdreiss/brewsage#readme) | A TUI for Homebrew |+| [`brick-trading-journal`](https://codeberg.org/amano.kenji/brick-trading-journal) | A TUI program that calculates basic statistics from trades |+| [`Brickudoku`](https://github.com/Thecentury/brickudoku) | A hybrid of Tetris and Sudoku |+| [`cbookview`](https://github.com/mlang/cbookview) | A TUI for exploring polyglot chess opening book files | | [`clifm`](https://github.com/pasqu4le/clifm) | A file manager |-| [`towerHanoi`](https://github.com/shajenM/projects/tree/master/towerHanoi) | Animated solutions to The Tower of Hanoi |-| [`VOIDSPACE`](https://github.com/ChrisPenner/void-space) | A space-themed typing-tutor game |-| [`solitaire`](https://github.com/ambuc/solitaire) | The card game |-| [`sudoku-tui`](https://github.com/evanrelf/sudoku-tui) | A Sudoku implementation |-| [`summoner-tui`](https://github.com/kowainik/summoner/tree/master/summoner-tui) | An interactive frontend to the Summoner tool |-| [`wrapping-editor`](https://github.com/ta0kira/wrapping-editor) | An embeddable editor with support for Brick |+| [`codenames-haskell`](https://github.com/VigneshN1997/codenames-haskell) | An implementation of the Codenames game |+| [`fifteen`](https://github.com/benjaminselfridge/fifteen) | An implementation of the [15 puzzle](https://en.wikipedia.org/wiki/15_puzzle) |+| [`ghcup`](https://www.haskell.org/ghcup/) | A TUI for `ghcup`, the Haskell toolchain manager | | [`git-brunch`](https://github.com/andys8/git-brunch) | A git branch checkout utility |+| [`Giter`](https://gitlab.com/refaelsh/giter) | A UI wrapper around Git CLI inspired by [Magit](https://magit.vc/). |+| [`gotta-go-fast`](https://github.com/callum-oakley/gotta-go-fast) | A typing tutor |+| [`haradict`](https://github.com/srhoulam/haradict) | A TUI Arabic dictionary powered by [ElixirFM](https://github.com/otakar-smrz/elixir-fm) | | [`hascard`](https://github.com/Yvee1/hascard) | A program for reviewing "flash card" notes |-| [`ttyme`](https://github.com/evuez/ttyme) | A TUI for [Harvest](https://www.getharvest.com/) |-| [`ghcup`](https://www.haskell.org/ghcup/) | A TUI for `ghcup`, the Haskell toolchain manager |-| [`cbookview`](https://github.com/mlang/chessIO) | A TUI for exploring polyglot chess opening book files |-| [`thock`](https://github.com/rmehri01/thock) | A modern TUI typing game featuring online racing against friends |-| [`fifteen`](https://github.com/benjaminselfridge/fifteen) | An implementation of the [15 puzzle](https://en.wikipedia.org/wiki/15_puzzle) |+| [`haskell-player`](https://github.com/potomak/haskell-player) | An `afplay` frontend |+| [`herms`](https://github.com/jackkiefer/herms) | A command-line tool for managing kitchen recipes |+| [`hic-hac-hoe`](https://github.com/blastwind/hic-hac-hoe) | Play tic tac toe in terminal! |+| [`hledger-iadd`](http://github.com/rootzlevel/hledger-iadd) | An interactive terminal UI for adding hledger journal entries |+| [`hledger-ui`](https://github.com/simonmichael/hledger) | A terminal UI for the hledger accounting system. |+| [`homodoro`](https://github.com/c0nradLC/homodoro) | A terminal application to use the pomodoro technique and keep track of daily tasks |+| [`hskanban`](https://github.com/vincentaxhe/hskanban) | A Kanban organizer |+| [`htyper`](https://github.com/Simon-Hostettler/htyper) | A typing speed test program |+| [`hyahtzee2`](https://github.com/DamienCassou/hyahtzee2#readme) | Famous Yahtzee dice game |+| [`kpxhs`](https://github.com/akazukin5151/kpxhs) | An interactive [Keepass](https://github.com/keepassxreboot/keepassxc/) database viewer |+| [`matterhorn`](https://github.com/matterhorn-chat/matterhorn) | A client for [Mattermost](https://about.mattermost.com/) | | [`maze`](https://github.com/benjaminselfridge/maze) | A Brick-based maze game |+| [`monad-torrent`](https://github.com/davorluc/monad-torrent) | A simple and minimal torrent client |+| [`monalog`](https://github.com/goosedb/Monalog) | Terminal logs observer |+| [`mushu`](https://github.com/elaye/mushu) | An `MPD` client |+| [`mywork`](https://github.com/kquick/mywork) [[Hackage]](https://hackage.haskell.org/package/mywork) | A tool to keep track of the projects you are working on | | [`pboy`](https://github.com/2mol/pboy) | A tiny PDF organizer |-| [`hyahtzee2`](https://github.com/DamienCassou/hyahtzee2#readme) | Famous Yahtzee dice game |-| [`brewsage`](https://github.com/gerdreiss/brewsage#readme) | A TUI for Homebrew |+| [`purebred`](https://github.com/purebred-mua/purebred) | A mail user agent | | [`sandwich`](https://codedownio.github.io/sandwich/) | A test framework with a TUI interface |-| [`youbrick`](https://github.com/florentc/youbrick) | A feed aggregator and launcher for Youtube channels |+| [`silly-joy`](https://github.com/rootmos/silly-joy) | An interpreter for Joy |+| [`solitaire`](https://github.com/ambuc/solitaire) | The card game |+| [`sudoku-tui`](https://github.com/evanrelf/sudoku-tui) | A Sudoku implementation |+| [`summoner-tui`](https://github.com/kowainik/summoner/tree/master/summoner-tui) | An interactive frontend to the Summoner tool | | [`swarm`](https://github.com/byorgey/swarm/) | A 2D programming and resource gathering game |-| [`hledger-ui`](https://github.com/simonmichael/hledger) | A terminal UI for the hledger accounting system. |-| [`hledger-iadd`](http://github.com/rootzlevel/hledger-iadd) | An interactive terminal UI for adding hledger journal entries |-| [`wordle`](https://github.com/ivanjermakov/wordle) | An implementation of the Wordle game |-| [`kpxhs`](https://github.com/akazukin5151/kpxhs) | An interactive [Keepass](https://github.com/keepassxreboot/keepassxc/) database viewer |-| [`htyper`](https://github.com/Simon-Hostettler/htyper) | A typing speed test program |+| [`tart`](https://github.com/jtdaugherty/tart) | A mouse-driven ASCII art drawing program |+| [`tick-tock-tui`](https://github.com/sectore/tick-tock-tui) | A stylish TUI app to handle Bitcoin data provided by [Mempool REST API](https://mempool.space/docs/api/rest) incl. blocks, fees and price converter. |+| [`tetris`](https://github.com/SamTay/tetris) | An implementation of the Tetris game |+| [`thock`](https://github.com/rmehri01/thock) | A modern TUI typing game featuring online racing against friends |+| [`timeloop`](https://github.com/cdupont/timeloop) | A time-travelling demonstrator |+| [`towerHanoi`](https://github.com/shajenM/projects/tree/master/towerHanoi) | Animated solutions to The Tower of Hanoi |+| [`ttyme`](https://github.com/evuez/ttyme) | A TUI for [Harvest](https://www.getharvest.com/) | | [`ullekha`](https://github.com/ajithnn/ullekha) | An interactive terminal notes/todo app with file/redis persistence |--These third-party packages also extend `brick`:--| Project | Description |-| ------- | ----------- |-| [`brick-filetree`](https://github.com/ChrisPenner/brick-filetree) [[Hackage]](http://hackage.haskell.org/package/brick-filetree) | A widget for exploring a directory tree and selecting or flagging files and directories |--Release Announcements / News-----------------------------+| [`viewprof`](https://github.com/maoe/viewprof) | A GHC profile viewer |+| [`VOIDSPACE`](https://github.com/ChrisPenner/void-space) | A space-themed typing-tutor game |+| [`wordle`](https://github.com/ivanjermakov/wordle) | An implementation of the Wordle game |+| [`wrapping-editor`](https://github.com/ta0kira/wrapping-editor) | An embeddable editor with support for Brick |+| [`youbrick`](https://github.com/florentc/youbrick) | A feed aggregator and launcher for Youtube channels | -Find out about `brick` releases and other news on Twitter:+These additional packages also extend `brick`: -https://twitter.com/brick_haskell/+| Project | Description | Hackage |+| ------- | ----------- | ------- |+| [`brick-filetree`](https://github.com/ChrisPenner/brick-filetree) | A widget for exploring a directory tree and selecting or flagging files and directories | [Hackage](https://hackage.haskell.org/package/brick-filetree) |+| [`brick-panes`](https://github.com/kquick/brick-panes) | A Brick overlay library providing composition and isolation of screen areas for TUI apps. | [Hackage](https://hackage.haskell.org/package/brick-panes) |+| [`brick-calendar`](https://github.com/ldgrp/brick-calendar) | A library providing a calendar widget for Brick-based applications. | [Hackage](https://hackage.haskell.org/package/brick-calendar) |+| [`brick-skylighting`](https://github.com/jtdaugherty/brick-skylighting) | A library providing integration support for [Skylighting](https://hackage.haskell.org/package/skylighting)-based syntax highlighting. | [Hackage](https://hackage.haskell.org/package/brick-skylighting) | Getting Started ---------------@@ -111,17 +125,17 @@ $ find dist-newstyle -type f -name \*-demo ``` -To get started, see the [user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst).+To get started, see the [user guide](https://github.com/jtdaugherty/brick/blob/main/docs/guide.rst). Documentation ------------- Documentation for `brick` comes in a variety of forms: -* [The official brick user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst)-* 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)+* [The official brick user guide](https://github.com/jtdaugherty/brick/blob/main/docs/guide.rst)+* [Haddock documentation](https://hackage.haskell.org/package/brick)+* [Demo programs](https://github.com/jtdaugherty/brick/blob/main/programs)+* [FAQ](https://github.com/jtdaugherty/brick/blob/main/FAQ.md) Feature Overview ----------------@@ -133,7 +147,9 @@ * List and table widgets * Progress bar widget * Simple dialog box widget+ * Menus and menu bars with optional custom keybinding integration * Border-drawing widgets (put borders around or in between things)+ * Animation support * Generic scrollable viewports and viewport scroll bars * General-purpose layout control combinators * Extensible widget-building API@@ -142,13 +158,14 @@ * A filesystem browser for file and directory selection * Borders can be configured to automatically connect! -Brick-Users Discussion-----------------------+Brick Discussion+---------------- -The `brick-users` Google Group / e-mail list is a place to discuss-library changes, give feedback, and ask questions. You can subscribe at:+There are two forums for discussing brick-related things: -[https://groups.google.com/group/brick-users](https://groups.google.com/group/brick-users)+1. The [Discussions page](https://github.com/jtdaugherty/brick/discussions) on the github repo, and+1. The `brick-users` Google Group / e-mail list. You can subscribe+ [here](https://groups.google.com/group/brick-users). Status ------@@ -168,14 +185,24 @@ packages and widgets. If you use that, you'll also be helping to test whether the exported interface is usable and complete! +A note on Windows support+-------------------------++Brick supports Windows implicitly by way of Vty's Windows support.+While I don't (and can't) personally test Brick on Windows hosts,+it should be possible to use Brick on Windows. If you have any+trouble, report any issues here. If needed, we'll migrate them to the+[vty-windows](https://github.com/chhackett/vty-windows) repository if+they need to be fixed there.+ Reporting bugs -------------- Please file bug reports as GitHub issues. For best results: - Include the versions of relevant software packages: your terminal- emulator, `brick`, `ghc`, and `vty` will be the most important- ones.+ emulator, `brick`, `ghc`, `vty`, and Vty platform packages will be+ the most important ones. - Clearly describe the behavior you expected ... @@ -188,6 +215,8 @@ If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: + - Patches written completely or partially by AI are unlikely to be+ accepted. Please disclose any AI use. - If you want to take on big things, talk to me first; let's have a design/vision discussion before you start coding. Create a GitHub issue and we can use that as the place to hash things out.@@ -195,7 +224,12 @@ codebase. - Please adjust or provide Haddock and/or user guide documentation relevant to any changes you make.- - New commits should be `-Wall` clean.+ - Please ensure that commits are `-Wall` clean.+ - Please ensure that each commit makes a single, logical, isolated+ change as much as possible.+ - Please do not submit changes that your linter told you to make. I+ will probably decline them. Relatedly: please do not submit changes+ that change only style without changing functionality. - Please do NOT include package version changes in your patches. Package version changes are only done at release time when the full scope of a release's changes can be evaluated to determine the
brick.cabal view
@@ -1,5 +1,5 @@ name: brick-version: 1.3+version: 3.0 synopsis: A declarative terminal user interface library description: Write terminal user interfaces (TUIs) painlessly with 'brick'! You@@ -20,9 +20,9 @@ . To get started, see: .- * <https://github.com/jtdaugherty/brick/blob/master/README.md The README>+ * <https://github.com/jtdaugherty/brick/blob/main/README.md The README> .- * The <https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst Brick user guide>+ * The <https://github.com/jtdaugherty/brick/blob/main/docs/guide.rst Brick user guide> . * The demonstration programs in the 'programs' directory .@@ -32,47 +32,30 @@ license-file: LICENSE author: Jonathan Daugherty <cygnus@foobox.com> maintainer: Jonathan Daugherty <cygnus@foobox.com>-copyright: (c) Jonathan Daugherty 2015-2022+copyright: (c) Jonathan Daugherty 2015-2026 category: Graphics build-type: Simple cabal-version: 1.18 Homepage: https://github.com/jtdaugherty/brick/ Bug-reports: https://github.com/jtdaugherty/brick/issues-tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, GHC == 9.4.2+tested-with: GHC == 9.0.2+ || == 9.2.8+ || == 9.4.8+ || == 9.6.7+ || == 9.8.4+ || == 9.10.3+ || == 9.12.2+ || == 9.14.1 extra-doc-files: README.md, docs/guide.rst, 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,- docs/programs-screenshots/brick-cache-demo.png,- docs/programs-screenshots/brick-custom-event-demo.png,- docs/programs-screenshots/brick-dialog-demo.png,- docs/programs-screenshots/brick-dynamic-border-demo.png,- docs/programs-screenshots/brick-edit-demo.png,- docs/programs-screenshots/brick-file-browser-demo.png,- docs/programs-screenshots/brick-fill-demo.png,- docs/programs-screenshots/brick-form-demo.png,- docs/programs-screenshots/brick-hello-world-demo.png,- docs/programs-screenshots/brick-layer-demo.png,- docs/programs-screenshots/brick-list-demo.png,- docs/programs-screenshots/brick-list-vi-demo.png,- docs/programs-screenshots/brick-mouse-demo.png,- docs/programs-screenshots/brick-padding-demo.png,- docs/programs-screenshots/brick-progressbar-demo.png,- docs/programs-screenshots/brick-readme-demo.png,- docs/programs-screenshots/brick-suspend-resume-demo.png,- docs/programs-screenshots/brick-text-wrap-demo.png,- docs/programs-screenshots/brick-theme-demo.png,- docs/programs-screenshots/brick-viewport-scroll-demo.png,- docs/programs-screenshots/brick-visibility-demo.png+ programs/custom_keys.ini Source-Repository head type: git- location: git://github.com/jtdaugherty/brick.git+ location: http://github.com/jtdaugherty/brick Flag demos Description: Build demonstration programs@@ -80,11 +63,12 @@ library default-language: Haskell2010- ghc-options: -Wall -Wcompat -O2+ ghc-options: -Wall -Wcompat -O2 -Wunused-packages default-extensions: CPP hs-source-dirs: src exposed-modules: Brick+ Brick.Animation Brick.AttrMap Brick.BChan Brick.BorderMap@@ -92,6 +76,7 @@ Brick.Keybindings.KeyConfig Brick.Keybindings.KeyEvents Brick.Keybindings.KeyDispatcher+ Brick.Keybindings.Normalize Brick.Keybindings.Parse Brick.Keybindings.Pretty Brick.Focus@@ -108,39 +93,46 @@ Brick.Widgets.Edit Brick.Widgets.FileBrowser Brick.Widgets.List+ Brick.Widgets.Menu+ Brick.Widgets.MenuBar Brick.Widgets.ProgressBar Brick.Widgets.Table Data.IMap other-modules:+ Brick.Animation.Clock Brick.Types.Common Brick.Types.TH Brick.Types.EventM Brick.Types.Internal Brick.Widgets.Internal - build-depends: base >= 4.9.0.0 && < 4.18.0.0,- vty >= 5.36,+ build-depends: base >= 4.9.0.0 && < 4.23.0.0,+ vty >= 6.0,+ vty-crossplatform, bimap >= 0.5 && < 0.6, data-clist >= 0.1, directory >= 1.2.5.0, exceptions >= 0.10.0, filepath, containers >= 0.5.7,- microlens >= 0.3.0.0,+ microlens-platform >= 0.3.0.0 && < 0.6,+ microlens, microlens-th, microlens-mtl, mtl, config-ini, vector,- contravariant, stm >= 2.4.3,- text,- text-zipper >= 0.12,+ text >= 2.1.2,+ text-zipper >= 0.13, template-haskell,- deepseq >= 1.3 && < 1.5,- unix,+ deepseq >= 1.3 && < 1.6,+ unix-compat, bytestring,- word-wrap >= 0.2+ word-wrap >= 0.2,+ unordered-containers,+ hashable,+ time executable brick-custom-keybinding-demo if !flag(demos)@@ -168,9 +160,7 @@ default-extensions: CPP main-is: TableDemo.hs build-depends: base,- brick,- text,- vty+ brick executable brick-tail-demo if !flag(demos)@@ -197,8 +187,7 @@ default-extensions: CPP main-is: ReadmeDemo.hs build-depends: base,- brick,- text+ brick executable brick-file-browser-demo if !flag(demos)@@ -227,6 +216,7 @@ text, microlens, microlens-th,+ vty-crossplatform, vty executable brick-text-wrap-demo@@ -239,7 +229,6 @@ main-is: TextWrapDemo.hs build-depends: base, brick,- text, word-wrap executable brick-cache-demo@@ -253,9 +242,6 @@ build-depends: base, brick, vty,- text,- microlens >= 0.3.0.0,- microlens-th, mtl executable brick-visibility-demo@@ -268,7 +254,6 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-th, microlens-mtl@@ -284,8 +269,7 @@ build-depends: base, brick, vty,- text,- microlens,+ vty-crossplatform, microlens-mtl, microlens-th @@ -299,9 +283,7 @@ main-is: ViewportScrollDemo.hs build-depends: base, brick,- vty,- text,- microlens+ vty executable brick-dialog-demo if !flag(demos)@@ -312,9 +294,7 @@ main-is: DialogDemo.hs build-depends: base, brick,- vty,- text,- microlens+ vty executable brick-mouse-demo if !flag(demos)@@ -326,11 +306,9 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-th, microlens-mtl,- text-zipper, mtl executable brick-layer-demo@@ -343,7 +321,6 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-th, microlens-mtl@@ -358,7 +335,6 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-th @@ -371,9 +347,7 @@ main-is: CroppingDemo.hs build-depends: base, brick,- vty,- text,- microlens+ vty executable brick-padding-demo if !flag(demos)@@ -384,9 +358,7 @@ main-is: PaddingDemo.hs build-depends: base, brick,- vty,- text,- microlens+ vty executable brick-theme-demo if !flag(demos)@@ -398,9 +370,7 @@ build-depends: base, brick, vty,- text,- mtl,- microlens+ mtl executable brick-attr-demo if !flag(demos)@@ -411,9 +381,22 @@ main-is: AttrDemo.hs build-depends: base, brick,+ vty++executable brick-tabular-list-demo+ if !flag(demos)+ Buildable: False+ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-language: Haskell2010+ main-is: TabularListDemo.hs+ build-depends: base,+ brick, vty,- text,- microlens+ microlens >= 0.3.0.0,+ microlens-mtl,+ microlens-th,+ vector executable brick-list-demo if !flag(demos)@@ -425,7 +408,6 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-mtl, mtl,@@ -441,12 +423,25 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-mtl, mtl, vector +executable brick-animation-demo+ if !flag(demos)+ Buildable: False+ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-language: Haskell2010+ main-is: AnimationDemo.hs+ build-depends: base,+ brick,+ vty,+ vty-crossplatform,+ containers,+ microlens-platform+ executable brick-custom-event-demo if !flag(demos) Buildable: False@@ -457,7 +452,6 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-th, microlens-mtl@@ -470,10 +464,7 @@ default-language: Haskell2010 main-is: FillDemo.hs build-depends: base,- brick,- vty,- text,- microlens+ brick executable brick-hello-world-demo if !flag(demos)@@ -483,10 +474,7 @@ default-language: Haskell2010 main-is: HelloWorldDemo.hs build-depends: base,- brick,- vty,- text,- microlens+ brick executable brick-edit-demo if !flag(demos)@@ -498,13 +486,24 @@ build-depends: base, brick, vty,- text,- vector,- mtl, microlens >= 0.3.0.0, microlens-th, microlens-mtl +executable brick-editor-line-numbers-demo+ if !flag(demos)+ Buildable: False+ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-language: Haskell2010+ main-is: EditorLineNumbersDemo.hs+ build-depends: base,+ brick,+ vty,+ microlens >= 0.3.0.0,+ microlens-th,+ microlens-mtl+ executable brick-border-demo if !flag(demos) Buildable: False@@ -516,8 +515,7 @@ build-depends: base, brick, vty,- text,- microlens+ text executable brick-dynamic-border-demo if !flag(demos)@@ -528,27 +526,73 @@ default-language: Haskell2010 main-is: DynamicBorderDemo.hs build-depends: base <= 5,+ brick++executable brick-progressbar-demo+ if !flag(demos)+ Buildable: False+ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-extensions: CPP+ default-language: Haskell2010+ main-is: ProgressBarDemo.hs+ build-depends: base, brick, vty,+ microlens-mtl,+ microlens-th++executable brick-menu-demo+ if !flag(demos)+ Buildable: False+ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-extensions: CPP+ default-language: Haskell2010+ main-is: MenuDemo.hs+ build-depends: base,+ brick,+ vty,+ mtl, text,- microlens+ microlens,+ microlens-mtl,+ microlens-th -executable brick-progressbar-demo+executable brick-menu-keybindings-demo if !flag(demos) Buildable: False hs-source-dirs: programs ghc-options: -threaded -Wall -Wcompat -O2 default-extensions: CPP default-language: Haskell2010- main-is: ProgressBarDemo.hs+ main-is: MenuKeybindingsDemo.hs build-depends: base, brick, vty,+ mtl, text, microlens, microlens-mtl, microlens-th +executable brick-menu-bar-demo+ if !flag(demos)+ Buildable: False+ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-extensions: CPP+ default-language: Haskell2010+ main-is: MenuBarDemo.hs+ build-depends: base,+ brick,+ vty,+ mtl,+ text,+ microlens,+ microlens-mtl,+ microlens-th+ test-suite brick-tests type: exitcode-stdio-1.0 hs-source-dirs: tests@@ -562,4 +606,5 @@ microlens, vector, vty,+ vty-crossplatform, QuickCheck
docs/guide.rst view
@@ -53,6 +53,13 @@ $ cd brick $ cabal new-build +Your package will need some dependencies:++* ``brick``,+* ``vty >= 6.0``, and+* ``vty-crossplatform`` or ``vty-unix`` or ``vty-windows``, depending+ on which platform(s) your application supports.+ Building the Demonstration Programs ----------------------------------- @@ -214,8 +221,8 @@ appHandleEvent :: BrickEvent n e -> EventM n s () ``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+based on incoming events. 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``.@@ -254,11 +261,11 @@ 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.+asynchronously when handling an event would otherwise cause redraw+latency. -Beyond I/O, ``EventM`` is used to make scrolling requests to the-renderer (see `Viewports`_), obtain named extents (see `Extents`_), and-other duties.+``EventM`` is also used to make scrolling requests to the renderer (see+`Viewports`_), obtain named extents (see `Extents`_), and other duties. Event Handlers for Component State **********************************@@ -291,7 +298,7 @@ .. code:: haskell - data MyState = MyState { _editor :: Editor Text n }+ data MyState n = MyState { _editor :: Editor Text n } makeLenses ''MyState This declares the ``MyState`` type with an ``Editor`` contained within@@ -403,7 +410,7 @@ main :: IO () main = do eventChan <- Brick.BChan.newBChan 10- let buildVty = Graphics.Vty.mkVty Graphics.Vty.defaultConfig+ let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig initialVty <- buildVty finalState <- customMain initialVty buildVty (Just eventChan) app initialState@@ -412,7 +419,11 @@ The ``customMain`` function lets us have control over how the ``vty`` library is initialized *and* how ``brick`` gets custom events to give to our event handler. ``customMain`` is the entry point into ``brick`` when-you need to use your own event type as shown here.+you need to use your own event type as shown here. In this example we're+using ``mkVty`` provided by the ``vty-crossplatform`` package, which+provides build-time support for both Unix and Windows. If you prefer,+you can use either the ``vty-unix`` package or the ``vty-windows``+package directly instead if you only want to support one platform. With all of this in place, sending our custom events to the event handler is straightforward:@@ -1187,8 +1198,10 @@ This approach finds all clicked extents and returns them in a list with the following properties: -* For extents ``A`` and ``B``, if ``A``'s layer is higher than ``B``'s- layer, ``A`` comes before ``B`` in the list.+* For matching extents ``A`` and ``B``, if ``A``'s layer is higher than+ ``B``'s layer, ``A`` is included in the results but ``B`` is not. This+ is because the layer containing ``A`` obscures the region ``B``, so it+ doesn't make sense to include it. * For extents ``A`` and ``B``, if ``A`` and ``B`` are in the same layer and ``A`` is contained within ``B``, ``A`` comes before ``B`` in the list.@@ -1649,8 +1662,8 @@ ``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:+runtime behaviors in a typical application to those of an application+that uses the customizable keybindings API: +---------------------+------------------------+-------------------------+ | **Approach** | **Before runtime** | **At runtime** |@@ -1745,12 +1758,12 @@ open and only handled ``QuitEvent`` when the window had been closed. This kind of "modal" approach to handling events means that we only consider a key to have a collision if it is bound to two or more- events that are handled in the same event handler.+ events that are handled in the same event handling context. -There's also another situation that would be problematic, which is when-an abstract event like ``QuitEvent`` has a key mapping that+There's also another situation that would be problematic, which is+when an abstract event like ``QuitEvent`` has a key mapping that collides with a key handler that is bound to a specific key using-``Brick.Keybindings.KeyDispatcher.onKey`` rather than an event:+``Brick.Keybindings.KeyDispatcher.onKey`` rather than an abstract event: .. code:: haskell @@ -1955,6 +1968,14 @@ so by consulting the ``ctxDynBorders`` field of the rendering context before writing to your ``Result``'s ``borders`` field. +Animations+==========++Brick provides animation support in ``Brick.Animation``. See the Haddock+documentation in that module for a complete explanation of the API; see+``programs/AnimationDemo.hs`` (``brick-animation-demo``) for a working+example.+ The Rendering Cache =================== @@ -1974,8 +1995,8 @@ border $ str "This will be cached" -In the example above, the first time the ``border $ str "This will be-cached"`` widget is rendered, the resulting Vty image will be stored+In the example above, the first time the ``border $ str "This will be cached"``+widget is rendered, the resulting Vty image will be stored in the rendering cache under the key ``ExpensiveThing``. On subsequent renderings the cached Vty image will be used instead of re-rendering the widget. This example doesn't need caching to improve performance, but
− docs/programs-screenshots.md
@@ -1,70 +0,0 @@-# Demo program screenshots--## [AttrDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/AttrDemo.hs)---## [BorderDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/BorderDemo.hs)---## [CacheDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/CacheDemo.hs)---## [CustomEventDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/CustomEventDemo.hs)---## [DialogDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/DialogDemo.hs)---## [DynamicBorderDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/DynamicBorderDemo.hs)---## [EditDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/EditDemo.hs)---## [FileBrowserDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/FileBrowserDemo.hs)---## [FillDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/FillDemo.hs)---## [FormDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/FormDemo.hs)---## [HelloWorldDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/HelloWorldDemo.hs)---## [LayerDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/LayerDemo.hs)---## [ListDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/ListDemo.hs)---## [ListViDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/ListViDemo.hs)---## [MouseDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/MouseDemo.hs)---## [PaddingDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/PaddingDemo.hs)---## [ProgressBarDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/ProgressBarDemo.hs)---## [ReadmeDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/ReadmeDemo.hs)---## [SuspendAndResumeDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/SuspendAndResumeDemo.hs)---## [TextWrapDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/TextWrapDemo.hs)---## [ThemeDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/ThemeDemo.hs)---## [ViewportScrollDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/ViewportScrollDemo.hs)---## [VisibilityDemo.hs](https://github.com/jtdaugherty/brick/blob/master/programs/VisibilityDemo.hs)-
− docs/programs-screenshots/brick-attr-demo.png
binary file changed (52808 → absent bytes)
− docs/programs-screenshots/brick-border-demo.png
binary file changed (19670 → absent bytes)
− docs/programs-screenshots/brick-cache-demo.png
binary file changed (44698 → absent bytes)
− docs/programs-screenshots/brick-custom-event-demo.png
binary file changed (12081 → absent bytes)
− docs/programs-screenshots/brick-dialog-demo.png
binary file changed (14232 → absent bytes)
− docs/programs-screenshots/brick-dynamic-border-demo.png
binary file changed (25746 → absent bytes)
− docs/programs-screenshots/brick-edit-demo.png
binary file changed (18668 → absent bytes)
− docs/programs-screenshots/brick-file-browser-demo.png
binary file changed (43038 → absent bytes)
− docs/programs-screenshots/brick-fill-demo.png
binary file changed (12794 → absent bytes)
− docs/programs-screenshots/brick-form-demo.png
binary file changed (20724 → absent bytes)
− docs/programs-screenshots/brick-hello-world-demo.png
binary file changed (10794 → absent bytes)
− docs/programs-screenshots/brick-layer-demo.png
binary file changed (22655 → absent bytes)
− docs/programs-screenshots/brick-list-demo.png
binary file changed (18011 → absent bytes)
− docs/programs-screenshots/brick-list-vi-demo.png
binary file changed (18448 → absent bytes)
− docs/programs-screenshots/brick-mouse-demo.png
binary file changed (35768 → absent bytes)
− docs/programs-screenshots/brick-padding-demo.png
binary file changed (22308 → absent bytes)
− docs/programs-screenshots/brick-progressbar-demo.png
binary file changed (16385 → absent bytes)
− docs/programs-screenshots/brick-readme-demo.png
binary file changed (11141 → absent bytes)
− docs/programs-screenshots/brick-suspend-resume-demo.png
binary file changed (12771 → absent bytes)
− docs/programs-screenshots/brick-text-wrap-demo.png
binary file changed (27669 → absent bytes)
− docs/programs-screenshots/brick-theme-demo.png
binary file changed (13429 → absent bytes)
− docs/programs-screenshots/brick-viewport-scroll-demo.png
binary file changed (32432 → absent bytes)
− docs/programs-screenshots/brick-visibility-demo.png
binary file changed (50627 → absent bytes)
+ programs/AnimationDemo.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+module Main where++import Control.Monad (void)+import Lens.Micro.Platform+import Data.List (intersperse)+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid+#endif+import qualified Data.Map as M+import qualified Graphics.Vty as V+import Graphics.Vty.CrossPlatform (mkVty)++import Brick.BChan+import Brick.Util (fg)+import Brick.Main (App(..), neverShowCursor, customMain, halt)+import Brick.AttrMap (AttrName, AttrMap, attrMap, attrName)+import Brick.Types (Widget, EventM, BrickEvent(..), Location(..))+import Brick.Widgets.Border (border)+import Brick.Widgets.Center (center)+import Brick.Widgets.Core ((<+>), str, vBox, hBox, hLimit, vLimit, translateLayer, withDefAttr)+import qualified Brick.Animation as A++data CustomEvent =+ AnimationUpdate (EventM () St ())+ -- ^ The state update constructor required by the animation API++data St =+ St { _stAnimationManager :: A.AnimationManager St CustomEvent ()+ -- ^ The animation manager that will run all of our animations+ , _animation1 :: Maybe (A.Animation St ())+ , _animation2 :: Maybe (A.Animation St ())+ , _animation3 :: Maybe (A.Animation St ())+ , _clickAnimations :: M.Map Location (A.Animation St ())+ -- ^ The various fields for storing animation states. For mouse+ -- animations, we store animations for each screen location that+ -- was clicked.+ }++makeLenses ''St++drawUI :: St -> [Widget ()]+drawUI st = drawClickAnimations st <> [drawAnimations st]++drawClickAnimations :: St -> [Widget ()]+drawClickAnimations st =+ drawClickAnimation st <$> M.toList (st^.clickAnimations)++drawClickAnimation :: St -> (Location, A.Animation St ()) -> Widget ()+drawClickAnimation st (l, a) =+ translateLayer l $+ A.renderAnimation (const $ str " ") st (Just a)++drawAnimations :: St -> Widget ()+drawAnimations st =+ let animStatus label key a =+ str (label <> ": ") <+>+ maybe (str "Not running") (const $ str "Running") a <+>+ str (" (Press " <> key <> " to toggle)")+ statusMessages = statusMessage <$> zip [(0::Int)..] animations+ statusMessage (i, (c, config)) =+ animStatus ("Animation #" <> (show $ i + 1)) [c]+ (st^.(animationTarget config))+ animationDrawings = hBox $ intersperse (str " ") $+ drawSingleAnimation <$> animations+ drawSingleAnimation (_, config) =+ A.renderAnimation (const $ str " ") st (st^.(animationTarget config))+ in vBox [ str "Click and drag the mouse or press keys to start animations."+ , str " "+ , vBox statusMessages+ , animationDrawings+ ]++clip1 :: A.Clip a ()+clip1 = A.newClip_ $ str <$> [".", "o", "O", "^", " "]++clip2 :: A.Clip a ()+clip2 = A.newClip_ $ str <$> ["|", "/", "-", "\\"]++clip3 :: A.Clip a ()+clip3 =+ A.newClip_ $+ (hLimit 9 . vLimit 9 . border . center) <$>+ [ border $ str " "+ , border $ vBox $ replicate 3 $ str $ replicate 3 ' '+ , border $ vBox $ replicate 5 $ str $ replicate 5 ' '+ ]++mouseClickClip :: A.Clip a ()+mouseClickClip =+ A.newClip_+ [ withDefAttr attr6 $ str "0"+ , withDefAttr attr5 $ str "O"+ , withDefAttr attr4 $ str "o"+ , withDefAttr attr3 $ str "•"+ , withDefAttr attr2 $ str "*"+ , withDefAttr attr2 $ str "."+ ]++attr6 :: AttrName+attr6 = attrName "attr6"++attr5 :: AttrName+attr5 = attrName "attr5"++attr4 :: AttrName+attr4 = attrName "attr4"++attr3 :: AttrName+attr3 = attrName "attr3"++attr2 :: AttrName+attr2 = attrName "attr2"++attr1 :: AttrName+attr1 = attrName "attr1"++attrs :: AttrMap+attrs =+ attrMap V.defAttr+ [ (attr6, fg V.white)+ , (attr5, fg V.brightYellow)+ , (attr4, fg V.brightGreen)+ , (attr3, fg V.cyan)+ , (attr2, fg V.blue)+ , (attr1, fg V.black)+ ]++-- | Animation settings grouped together for lookup by keystroke.+data AnimationConfig =+ AnimationConfig { animationTarget :: Lens' St (Maybe (A.Animation St ()))+ , animationClip :: A.Clip St ()+ , animationFrameTime :: Integer+ , animationMode :: A.RunMode+ }++animations :: [(Char, AnimationConfig)]+animations =+ [ ('1', AnimationConfig animation1 clip1 1000 A.Loop)+ , ('2', AnimationConfig animation2 clip2 100 A.Loop)+ , ('3', AnimationConfig animation3 clip3 100 A.Once)+ ]++-- | Start the animation specified by this config.+startAnimationFromConfig :: AnimationConfig -> EventM () St ()+startAnimationFromConfig config = do+ mgr <- use stAnimationManager+ A.startAnimation mgr (animationClip config)+ (animationFrameTime config)+ (animationMode config)+ (animationTarget config)++-- | If the animation specified in this config is not running, start it.+-- Otherwise stop it.+toggleAnimationFromConfig :: AnimationConfig -> EventM () St ()+toggleAnimationFromConfig config = do+ mgr <- use stAnimationManager+ mOld <- use (animationTarget config)+ case mOld of+ Just a -> A.stopAnimation mgr a+ Nothing -> startAnimationFromConfig config++-- | Start a new mouse click animation at the specified location if one+-- is not already running there.+startMouseClickAnimation :: Location -> EventM () St ()+startMouseClickAnimation l = do+ mgr <- use stAnimationManager+ a <- use (clickAnimations.at l)+ case a of+ Just {} -> return ()+ Nothing -> A.startAnimation mgr mouseClickClip 100 A.Once (clickAnimations.at l)++appEvent :: BrickEvent () CustomEvent -> EventM () St ()+appEvent e = do+ case e of+ -- A mouse click starts an animation at the click location.+ VtyEvent (V.EvMouseDown col row _ _) ->+ startMouseClickAnimation (Location (col, row))++ -- If we got a character keystroke, see if there is a specific+ -- animation mapped to that character and toggle the resulting+ -- animation.+ VtyEvent (V.EvKey (V.KChar c) [])+ | Just aConfig <- lookup c animations ->+ toggleAnimationFromConfig aConfig++ -- Apply a state update from the animation manager.+ AppEvent (AnimationUpdate act) -> act++ VtyEvent (V.EvKey V.KEsc []) -> halt++ _ -> return ()++theApp :: App St CustomEvent ()+theApp =+ App { appDraw = drawUI+ , appChooseCursor = neverShowCursor+ , appHandleEvent = appEvent+ , appStartEvent = return ()+ , appAttrMap = const attrs+ }++main :: IO ()+main = do+ chan <- newBChan 10+ mgr <- A.startAnimationManager 50 chan AnimationUpdate++ let initialState =+ St { _stAnimationManager = mgr+ , _animation1 = Nothing+ , _animation2 = Nothing+ , _animation3 = Nothing+ , _clickAnimations = mempty+ }+ buildVty = do+ v <- mkVty V.defaultConfig+ V.setMode (V.outputIface v) V.Mouse True+ return v++ initialVty <- buildVty+ void $ customMain initialVty buildVty (Just chan) theApp initialState
programs/BorderDemo.hs view
@@ -16,16 +16,17 @@ ( Widget ) import Brick.Widgets.Core- ( (<=>)- , (<+>)+ ( (<+>) , withAttr , vLimit , hLimit , hBox+ , vBox , updateAttrMap , withBorderStyle , txt , str+ , padLeftRight ) import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B@@ -65,20 +66,23 @@ B.borderWithLabel (str "label") $ vLimit 5 $ C.vCenter $- txt $ " " <> styleName <> " style "+ padLeftRight 2 $+ txt $ styleName <> " style" titleAttr :: A.AttrName titleAttr = A.attrName "title" -borderMappings :: [(A.AttrName, V.Attr)]-borderMappings =+attrs :: [(A.AttrName, V.Attr)]+attrs = [ (B.borderAttr, V.yellow `on` V.black)+ , (B.vBorderAttr, fg V.cyan)+ , (B.hBorderAttr, fg V.magenta) , (titleAttr, fg V.cyan) ] colorDemo :: Widget () colorDemo =- updateAttrMap (A.applyAttrMappings borderMappings) $+ updateAttrMap (A.applyAttrMappings attrs) $ B.borderWithLabel (withAttr titleAttr $ str "title") $ hLimit 20 $ vLimit 5 $@@ -87,13 +91,14 @@ ui :: Widget () ui =- hBox borderDemos- <=> B.hBorder- <=> colorDemo- <=> B.hBorderWithLabel (str "horizontal border label")- <=> (C.center (str "Left of vertical border")- <+> B.vBorder- <+> C.center (str "Right of vertical border"))+ vBox [ hBox borderDemos+ , B.hBorder+ , colorDemo+ , B.hBorderWithLabel (str "horizontal border label")+ , (C.center (str "Left of vertical border")+ <+> B.vBorder+ <+> C.center (str "Right of vertical border"))+ ] main :: IO () main = M.simpleMain ui
programs/CustomEventDemo.hs view
@@ -17,7 +17,7 @@ import Brick.Main ( App(..) , showFirstCursor- , customMain+ , customMainWithDefaultVty , halt ) import Brick.AttrMap@@ -82,6 +82,5 @@ writeBChan chan Counter threadDelay 1000000 - let buildVty = V.mkVty V.defaultConfig- initialVty <- buildVty- void $ customMain initialVty buildVty (Just chan) theApp initialState+ (_, vty) <- customMainWithDefaultVty (Just chan) theApp initialState+ V.shutdown vty
programs/DialogDemo.hs view
@@ -25,12 +25,18 @@ data Choice = Red | Blue | Green deriving Show -drawUI :: D.Dialog Choice -> [Widget ()]+data Name =+ RedButton+ | BlueButton+ | GreenButton+ deriving (Show, Eq, Ord)++drawUI :: D.Dialog Choice Name -> [Widget Name] drawUI d = [ui] where ui = D.renderDialog d $ C.hCenter $ padAll 1 $ str "This is the dialog body." -appEvent :: BrickEvent () e -> T.EventM () (D.Dialog Choice) ()+appEvent :: BrickEvent Name e -> T.EventM Name (D.Dialog Choice Name) () appEvent (VtyEvent ev) = case ev of V.EvKey V.KEsc [] -> M.halt@@ -38,12 +44,12 @@ _ -> D.handleDialogEvent ev appEvent _ = return () -initialState :: D.Dialog Choice-initialState = D.dialog (Just "Title") (Just (0, choices)) 50+initialState :: D.Dialog Choice Name+initialState = D.dialog (Just $ str "Title") (Just (RedButton, choices)) 50 where- choices = [ ("Red", Red)- , ("Blue", Blue)- , ("Green", Green)+ choices = [ ("Red", RedButton, Red)+ , ("Blue", BlueButton, Blue)+ , ("Green", GreenButton, Green) ] theMap :: A.AttrMap@@ -53,7 +59,7 @@ , (D.buttonSelectedAttr, bg V.yellow) ] -theApp :: M.App (D.Dialog Choice) e ()+theApp :: M.App (D.Dialog Choice Name) e Name theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor
+ programs/EditorLineNumbersDemo.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+module Main where++import Control.Monad (void)+import Lens.Micro+import Lens.Micro.TH+import Lens.Micro.Mtl+import qualified Graphics.Vty as V+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif++import qualified Brick.Main as M+import qualified Brick.Types as T+import Brick.Widgets.Core+ ( (<+>)+ , vBox+ , hLimit+ , vLimit+ , str+ , visible+ , viewport+ , withDefAttr+ )+import qualified Brick.Widgets.Center as C+import qualified Brick.Widgets.Edit as E+import qualified Brick.AttrMap as A+import Brick.Util (on, fg)++data Name = Edit+ | EditLines+ deriving (Ord, Show, Eq)++data St =+ St { _edit :: E.Editor String Name+ }++makeLenses ''St++drawUI :: St -> [T.Widget Name]+drawUI st = [ui]+ where+ e = renderWithLineNumbers (st^.edit)+ ui = C.center $ hLimit 50 $ vLimit 10 e++-- | Given an editor, render the editor with line numbers to the left of+-- the editor.+--+-- This essentially exploits knowledge of how the editor is implemented:+-- we make a viewport containing line numbers that is just as high as+-- the editor, then request that the line number associated with the+-- editor's current line position be made visible, thus scrolling it+-- into view. This is slightly brittle, however, because it relies on+-- essentially keeping the line number viewport and the editor viewport+-- in the same vertical scrolling state; with direct scrolling requests+-- from EventM it is easily possible to put the two viewports into a+-- state where they do not have the same vertical scrolling offset. That+-- means that visibility requests made with 'visible' won't necessarily+-- have the same effect in each viewport in that case. So this is+-- only really usable in the case where you're sure that the editor's+-- viewport and the line number viewports will not be managed by direct+-- viewport operations in EventM. That's what I'd recommend anyway, but+-- still, this is an important caveat.+--+-- There's another important caveat here: this particular implementation+-- has @O(n)@ performance for editor height @n@ because we generate+-- the entire list of line numbers on each rendering depending on the+-- height of the editor. That means that for sufficiently large files,+-- it will get more expensive to render the line numbers. There is a way+-- around this problem, which is to take the approach that the @List@+-- implementation takes: only render a region of visible line numbers+-- around the currently-edited line that is just large enough to be+-- guaranteed to fill the viewport, then translate that so that it+-- appears at the right viewport offset, thus faking a viewport filled+-- with line numbers when in fact we'd only ever render at most @2 * K ++-- 1@ line numbers for a viewport height of @K@. That's more involved,+-- so I didn't do it here, but that would be the way to go for a Real+-- Application.+renderWithLineNumbers :: E.Editor String Name -> T.Widget Name+renderWithLineNumbers e =+ lineNumbersVp <+> editorVp+ where+ lineNumbersVp = hLimit (maxNumWidth + 1) $ viewport EditLines T.Vertical body+ editorVp = E.renderEditor (str . unlines) True e+ body = withDefAttr lineNumberAttr $ vBox numWidgets+ numWidgets = mkNumWidget <$> numbers+ mkNumWidget i = maybeVisible i $ str $ show i+ maybeVisible i+ | i == curLine + 1 =+ visible . withDefAttr currentLineNumberAttr+ | otherwise =+ id+ numbers = [1..h]+ contents = E.getEditContents e+ h = length contents+ curLine = fst $ E.getCursorPosition e+ maxNumWidth = length $ show h++appEvent :: T.BrickEvent Name e -> T.EventM Name St ()+appEvent (T.VtyEvent (V.EvKey V.KEsc [])) =+ M.halt+appEvent ev = do+ zoom edit $ E.handleEditorEvent ev++initialState :: St+initialState =+ St (E.editor Edit Nothing "")++lineNumberAttr :: A.AttrName+lineNumberAttr = A.attrName "lineNumber"++currentLineNumberAttr :: A.AttrName+currentLineNumberAttr = lineNumberAttr <> A.attrName "current"++theMap :: A.AttrMap+theMap = A.attrMap V.defAttr+ [ (E.editAttr, V.white `on` V.blue)+ , (E.editFocusedAttr, V.black `on` V.yellow)+ , (lineNumberAttr, fg V.cyan)+ , (currentLineNumberAttr, V.defAttr `V.withStyle` V.bold)+ ]++theApp :: M.App St e Name+theApp =+ M.App { M.appDraw = drawUI+ , M.appChooseCursor = const $ M.showCursorNamed Edit+ , M.appHandleEvent = appEvent+ , M.appStartEvent = return ()+ , M.appAttrMap = const theMap+ }++main :: IO ()+main = do+ void $ M.defaultMain theApp initialState
programs/FormDemo.hs view
@@ -11,6 +11,8 @@ #endif import qualified Graphics.Vty as V+import Graphics.Vty.CrossPlatform (mkVty)+ import Brick import Brick.Forms ( Form@@ -104,7 +106,7 @@ help = padTop (Pad 1) $ B.borderWithLabel (str "Help") body body = str $ "- Name is free-form text\n" <> "- Age must be an integer (try entering an\n" <>- " invalid age!)\n" <>+ " invalid age or an age less than 18!)\n" <> "- Handedness selects from a list of options\n" <> "- The last option is a checkbox\n" <> "- Enter/Esc quit, mouse interacts with fields"@@ -136,7 +138,7 @@ main :: IO () main = do let buildVty = do- v <- V.mkVty =<< V.standardIOConfig+ v <- mkVty V.defaultConfig V.setMode (V.outputIface v) V.Mouse True return v
programs/LayerDemo.hs view
@@ -17,11 +17,12 @@ import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Center as C import Brick.Widgets.Core- ( translateBy+ ( translateLayer , str- , relativeTo+ , layerRelativeTo , reportExtent , withDefAttr+ , above ) import Brick.Util (fg) import Brick.AttrMap@@ -45,29 +46,40 @@ drawUi st = [ C.centerLayer $ B.border $ str "This layer is centered but other\nlayers are placed underneath it."- , arrowLayer- , middleLayer st- , bottomLayer st+ , arrowLayer1+ , arrowLayer2 `above` (middleLayer (st^.middleLayerLocation))+ , bottomLayer (st^.bottomLayerLocation) ] -arrowLayer :: Widget Name-arrowLayer =+arrowLayer1 :: Widget Name+arrowLayer1 = let msg = "Relatively\n" <>+ "positioned with\n" <>+ "'layerRelativeTo'"+ in layerRelativeTo MiddleLayerElement (Location (-18, -4)) $+ withDefAttr arrowAttr $+ B.border $+ str msg++arrowLayer2 :: Widget Name+arrowLayer2 =+ let msg = "Relatively\n" <> "positioned\n" <>- "arrow---->"- in relativeTo MiddleLayerElement (Location (-10, -2)) $+ "with 'above'"+ in translateLayer (Location (18, 3)) $ withDefAttr arrowAttr $+ B.border $ str msg -middleLayer :: St -> Widget Name-middleLayer st =- translateBy (st^.middleLayerLocation) $+middleLayer :: Location -> Widget Name+middleLayer l =+ translateLayer l $ reportExtent MiddleLayerElement $ B.border $ str "Middle layer\n(Arrow keys move)" -bottomLayer :: St -> Widget Name-bottomLayer st =- translateBy (st^.bottomLayerLocation) $+bottomLayer :: Location -> Widget Name+bottomLayer l =+ translateLayer l $ B.border $ str "Bottom layer\n(Ctrl-arrow keys move)" appEvent :: T.BrickEvent Name e -> T.EventM Name St ()
programs/ListDemo.hs view
@@ -8,7 +8,6 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif-import Data.Maybe (fromMaybe) import qualified Graphics.Vty as V import qualified Brick.Main as M@@ -43,20 +42,25 @@ hLimit 25 $ vLimit 15 $ L.renderList listDrawElement True l+ wrapStatus = if L.getScrollWrap l+ then "enabled"+ else "disabled" ui = C.vCenter $ vBox [ C.hCenter box , str " " , C.hCenter $ str "Press +/- to add/remove list elements." , C.hCenter $ str "Press Esc to exit."+ , str " "+ , C.hCenter $ str "Press 'w' to toggle selection wrapping."+ , C.hCenter $ str $ "Selection wrapping is currently " <> wrapStatus <> "." ] -appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Char) ()+appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Int) () appEvent (T.VtyEvent e) = case e of V.EvKey (V.KChar '+') [] -> do els <- use L.listElementsL- let el = nextElement els- pos = Vec.length els- modify $ L.listInsert pos el+ let pos = Vec.length els+ modify $ L.listInsert pos pos V.EvKey (V.KChar '-') [] -> do sel <- use L.listSelectedL@@ -64,14 +68,17 @@ Nothing -> return () Just i -> modify $ L.listRemove i + V.EvKey (V.KChar 'w') [] ->+ toggleListWrapping+ V.EvKey V.KEsc [] -> M.halt ev -> L.handleListEvent ev- where- nextElement :: Vec.Vector Char -> Char- nextElement v = fromMaybe '?' $ Vec.find (flip Vec.notElem v) (Vec.fromList ['a' .. 'z']) appEvent _ = return () +toggleListWrapping :: T.EventM () (L.List () Int) ()+toggleListWrapping = L.listScrollWrapL %= not+ listDrawElement :: (Show a) => Bool -> a -> Widget () listDrawElement sel a = let selStr s = if sel@@ -79,8 +86,8 @@ else str s in C.hCenter $ str "Item " <+> (selStr $ show a) -initialState :: L.List () Char-initialState = L.list () (Vec.fromList ['a','b','c']) 1+initialState :: L.List () Int+initialState = L.list () (Vec.fromList [0..2000]) 1 customAttr :: A.AttrName customAttr = L.listSelectedAttr <> A.attrName "custom"@@ -92,7 +99,7 @@ , (customAttr, fg V.cyan) ] -theApp :: M.App (L.List () Char) e ()+theApp :: M.App (L.List () Int) e () theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor
+ programs/MenuBarDemo.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Lens.Micro ((^.))+import Lens.Micro.TH (makeLenses)+import Lens.Micro.Mtl ((%=), use)+import Control.Monad (void, when)+import Control.Monad.Trans (liftIO)+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif+import qualified Data.Text as Text+import qualified Graphics.Vty as V++import qualified Brick.Types as T+import Brick.AttrMap+import Brick.Util+import Brick.Types (Widget)+import qualified Brick.Main as M+import Brick.Widgets.Core (txtWrap, hLimit)+import Brick.Widgets.Center (center)+import Brick.Widgets.Menu+import Brick.Widgets.MenuBar++data Name = FileMenu MenuRegion+ | EditMenu MenuRegion+ | HelpMenu MenuRegion+ deriving (Show, Ord, Eq)++data St =+ St { _menuBar :: SimpleMenuBar St Name+ , _menuBarOrientation :: MenuOrientation+ }++makeLenses ''St++drawUi :: St -> [Widget Name]+drawUi st =+ [ renderMenuBar st (st^.menuBar)+ , center $+ hLimit 40 $+ txtWrap $+ Text.unlines $+ [ "Click the menu title with the mouse or press Alt-F, Alt-E, " <>+ "or Alt-H to open the menus."+ , ""+ , "Press 'o' to toggle the orientation of the menu bar and its menus."+ , ""+ , "When a menu is open:"+ , ""+ , "- Press up/down arrow keys to select items and then " <>+ "press Enter to activate them, or click them with the mouse instead."+ , ""+ , "- Press left/right arrow keys cycle through open menus."+ , ""+ , "Press Esc to quit the program."+ ]+ ]++appEvent :: T.BrickEvent Name e -> T.EventM Name St ()+appEvent e = do+ handled <- handleMenuBarEvent menuBar e+ when (not handled) $ handleNonMenuBarEvent e++handleNonMenuBarEvent :: T.BrickEvent Name e -> T.EventM Name St ()+handleNonMenuBarEvent (T.VtyEvent (V.EvKey V.KEsc [])) =+ -- Esc quits the application+ M.halt+handleNonMenuBarEvent (T.VtyEvent (V.EvKey (V.KChar 'f') [V.MMeta])) =+ menuBar %= toggleMenuAtIndex 0+handleNonMenuBarEvent (T.VtyEvent (V.EvKey (V.KChar 'e') [V.MMeta])) =+ menuBar %= toggleMenuAtIndex 1+handleNonMenuBarEvent (T.VtyEvent (V.EvKey (V.KChar 'h') [V.MMeta])) =+ menuBar %= toggleMenuAtIndex 2+handleNonMenuBarEvent (T.VtyEvent (V.EvKey (V.KChar 'o') [])) = do+ menuBarOrientation %= nextOrientation+ o <- use menuBarOrientation+ menuBar %= setMenuBarOrientation o+handleNonMenuBarEvent _ =+ return ()++nextOrientation :: MenuOrientation -> MenuOrientation+nextOrientation LeftToRight = RightToLeft+nextOrientation RightToLeft = LeftToRight++aMap :: AttrMap+aMap = attrMap V.defAttr+ [ (menuAttr, fg V.white)+ , (menuTitleAttr, V.white `on` V.blue)+ , (menuTitleSelectedAttr, V.black `on` V.white)+ , (menuEntryDisabledAttr, fg V.red)+ , (menuEntrySelectedAttr, V.black `on` V.yellow)+ , (menuEntrySelectedDisabledAttr, V.black `on` V.red)+ , (menuTitleKeyHighlightAttr, style V.underline)+ ]++app :: M.App St e Name+app =+ M.App { M.appDraw = drawUi+ , 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+ }++newFileMenu :: SimpleMenu St Name+newFileMenu =+ setTitleRenderer (titleHightlightKey 'f') $+ simpleMenu "File" FileMenu+ [ menuEntry "New..." (return ())+ , menuEntry "Open..." (return ())+ , menuSeparator+ , menuEntry "Exit" M.halt+ ]++newEditMenu :: SimpleMenu St Name+newEditMenu =+ setTitleRenderer (titleHightlightKey 'e') $+ simpleMenu "Edit" EditMenu+ [ menuEntry "Undo" (return ())+ , menuEntry "Redo" (return ())+ , menuSeparator+ , menuEntry "Cut" (return ())+ , menuEntry "Copy" (return ())+ , menuEntry "Paste" (return ())+ ]++newHelpMenu :: SimpleMenu St Name+newHelpMenu =+ setTitleRenderer (titleHightlightKey 'h') $+ simpleMenu "Help" HelpMenu+ [ menuEntry "About" (return ())+ , menuEntry "Check for updates" (return ())+ ]++main :: IO ()+main = do+ let mb = newMenuBar [ newFileMenu+ , newEditMenu+ , newHelpMenu+ ]+ void $ M.defaultMain app $ St mb LeftToRight
+ programs/MenuDemo.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Lens.Micro ((^.))+import Lens.Micro.TH (makeLenses)+import Lens.Micro.Mtl+import Control.Monad (void, when)+import Control.Monad.Trans (liftIO)+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif+import qualified Data.Text as Text+import qualified Graphics.Vty as V++import qualified Brick.Types as T+import Brick.AttrMap+import Brick.Util+import Brick.Types (Widget)+import qualified Brick.Main as M+import Brick.Widgets.Core (txtWrap, hLimit, padLeft, Padding(..), withBorderStyle)+import Brick.Widgets.Center (center)+import qualified Brick.Widgets.Border.Style as S+import Brick.Widgets.Menu++data Name = FileMenu MenuRegion+ | ExportMenu MenuRegion+ deriving (Show, Ord, Eq)++data St =+ St { _fileMenu :: SimpleMenu St Name+ , _borderStyle :: S.BorderStyle+ }++makeLenses ''St++drawUi :: St -> [Widget Name]+drawUi st =+ [ padLeft (Pad 1) $+ withBorderStyle (st^.borderStyle) $+ renderMenu st (st^.fileMenu)+ , center $+ hLimit 60 $+ txtWrap $+ Text.unlines $+ [ "Click the menu title with the mouse or press Alt-F to open the menu."+ , ""+ , "When the menu is open, press arrow keys to select items and then " <>+ "press Enter to activate them, or click them with the mouse instead."+ , ""+ , "When the menu is open, press Enter or the right arrow key to open " <>+ "the submenu; press Esc or the left arrow key to close it."+ , ""+ , "Press these keys to switch menu border styles:"+ , ""+ ] <>+ [ "- " <> Text.singleton c <> ": " <> label | (c, (label, _)) <- borderStyles] <>+ [ ""+ , "Press Esc to quit the program."+ ]+ ]++borderStyles :: [(Char, (Text.Text, S.BorderStyle))]+borderStyles =+ [ ('1', ("Unicode (default)", S.unicode))+ , ('2', ("Unicode rounded", S.unicodeRounded))+ , ('3', ("Unicode bold", S.unicodeBold))+ , ('4', ("ASCII", S.ascii))+ ]++appEvent :: T.BrickEvent Name e -> T.EventM Name St ()+appEvent (T.VtyEvent (V.EvKey (V.KChar 'f') [V.MMeta])) =+ fileMenu %= toggleMenu+appEvent (T.VtyEvent (V.EvKey (V.KChar c) [])) =+ case lookup c borderStyles of+ Nothing -> return ()+ Just (_, s) -> borderStyle .= s+appEvent e = do+ handled <- handleMenuEvent fileMenu e+ when (not handled) $ handleNonMenuEvent e++handleNonMenuEvent :: T.BrickEvent Name e -> T.EventM Name St ()+handleNonMenuEvent (T.VtyEvent (V.EvKey V.KEsc [])) =+ -- Esc quits the application+ M.halt+handleNonMenuEvent _ =+ return ()++aMap :: AttrMap+aMap = attrMap V.defAttr+ [ (menuAttr, fg V.white)+ , (menuTitleAttr, fg V.white)+ , (menuTitleSelectedAttr, V.black `on` V.white)+ , (menuEntryDisabledAttr, fg V.red)+ , (menuEntrySelectedAttr, V.black `on` V.yellow)+ , (menuEntrySelectedDisabledAttr, V.black `on` V.red)+ , (menuTitleKeyHighlightAttr, style V.underline)+ ]++app :: M.App St e Name+app =+ M.App { M.appDraw = drawUi+ , 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+ }++newFileMenu :: SimpleMenu St Name+newFileMenu =+ setTitleRenderer (titleHightlightKey 'f') $+ simpleMenu "File" FileMenu+ [ menuEntry "New..." (return ())+ , menuEntry "Open..." (return ())+ , menuSeparator+ , submenu $ simpleMenu "Export" ExportMenu+ [ menuEntry "JPEG" (return ())+ , menuEntry "PNG" (return ())+ , menuEntry "GIF" (return ())+ ]+ , menuSeparator+ , menuEntry "Exit" M.halt+ ]++main :: IO ()+main = void $ M.defaultMain app $ St newFileMenu S.unicode
+ programs/MenuKeybindingsDemo.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Lens.Micro ((^.))+import Lens.Micro.TH (makeLenses)+import Lens.Micro.Mtl+import Control.Monad (void, forM_)+import Control.Monad.Trans (liftIO)+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif+import Data.Maybe (fromJust)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Graphics.Vty as V+import System.Exit (exitFailure)++import qualified Brick.Types as T+import Brick.AttrMap+import Brick.Util+import Brick.Types (Widget)+import qualified Brick.Main as M+import Brick.Widgets.Core ((<=>), txt, withAttr, txtWrap, hLimit, padLeft, Padding(..))+import Brick.Widgets.Center (center)+import Brick.Widgets.Menu++import qualified Brick.Keybindings as K++-- | The abstract key events for the application.+data KeyEvent = QuitEvent+ | ToggleFileMenuEvent+ | NewEvent+ | OpenEvent+ deriving (Ord, Eq, Show)++-- | The mapping of key events to their configuration field names.+allKeyEvents :: K.KeyEvents KeyEvent+allKeyEvents =+ K.keyEvents [ ("quit", QuitEvent)+ , ("toggle-file-menu", ToggleFileMenuEvent)+ , ("new", NewEvent)+ , ("open", OpenEvent)+ ]++-- | Default key bindings for each abstract key event.+defaultBindings :: [(KeyEvent, [K.Binding])]+defaultBindings =+ [ (QuitEvent, [K.ctrl 'q'])+ , (ToggleFileMenuEvent, [K.meta 'f'])+ , (NewEvent, [K.meta 'n'])+ , (OpenEvent, [K.meta 'o'])+ ]++data Name = FileMenu MenuRegion+ deriving (Show, Ord, Eq)++data St =+ St { _keyConfig :: K.KeyConfig KeyEvent+ , _dispatcher :: K.KeyDispatcher KeyEvent (T.EventM Name St)+ , _fileMenu :: DispatchingMenu St Name KeyEvent+ , _lastAction :: Text.Text+ }++makeLenses ''St++drawUi :: St -> [Widget Name]+drawUi st =+ [ padLeft (Pad 1) $+ renderMenu st (st^.fileMenu)+ , center $+ hLimit 60 $+ (txtWrap $+ Text.unlines $+ [ "Click the menu title with the mouse or press Alt-F to open the menu."+ , ""+ , "When the menu is open, press arrow keys to select items and then " <>+ "press Enter to activate them, or click them with the mouse instead."+ , ""+ , "When the menu is open or closed, press the keybindings shown in the " <>+ "menu to activate the corresponding menu items."+ , ""+ ])+ <=>+ (withAttr emphAttr $+ txt $ "Last action: " <> st^.lastAction)+ ]++-- | Key event handlers for our application.+handlers :: [K.KeyEventHandler KeyEvent (T.EventM n St)]+handlers =+ [ K.onEvent QuitEvent "Quit the program" M.halt++ , K.onEvent ToggleFileMenuEvent "Toggle the File menu" $ do+ lastAction .= "Toggled the File menu"+ fileMenu %= toggleMenu++ , K.onEvent NewEvent "New" $+ lastAction .= "Activated New... menu entry"++ , K.onEvent OpenEvent "Open" $+ lastAction .= "Activated Open... menu entry"++ , K.onKey (K.ctrl 't') "Fixed key" $+ lastAction .= "Activated fixed-key event handler"+ ]++appEvent :: T.BrickEvent Name e -> T.EventM Name St ()+appEvent e = void $ handleMenuEvent fileMenu e++emphAttr :: AttrName+emphAttr = attrName "emphasis"++aMap :: AttrMap+aMap = attrMap V.defAttr+ [ (menuAttr, fg V.white)+ , (menuTitleAttr, fg V.white)+ , (menuTitleSelectedAttr, V.black `on` V.white)+ , (menuEntryDisabledAttr, fg V.red)+ , (menuEntrySelectedAttr, V.black `on` V.yellow)+ , (menuEntrySelectedDisabledAttr, V.black `on` V.red)+ , (menuEntryKeybindingAttr, fg V.cyan `V.withStyle` V.bold)+ , (emphAttr, fg V.white)+ ]++app :: M.App St e Name+app =+ M.App { M.appDraw = drawUi+ , 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+ }++newFileMenu :: K.KeyDispatcher KeyEvent (T.EventM Name St) -> DispatchingMenu St Name KeyEvent+newFileMenu d =+ menuWithDispatcher d "File" FileMenu+ [ menuEntryForEvent "New..." NewEvent+ , menuEntryForEvent "Open..." OpenEvent+ , menuEntryForKey "Test" (K.ctrl 't')+ , menuEntryForAction "Test 2" (lastAction .= "Activated 'Test 2' item")+ , menuSeparator+ , menuEntryForEvent "Exit" QuitEvent+ ]++sectionName :: Text.Text+sectionName = "keybindings"++main :: IO ()+main = do+ -- Create a key config that includes the default bindings.+ let kc = K.newKeyConfig allKeyEvents defaultBindings []++ -- Build a key dispatcher for our event handlers. If this fails+ -- due to key collision detection, we'll print out info about the+ -- collisions.+ d <- case K.keyDispatcher kc handlers of+ Right d -> return d+ Left collisions -> do+ putStrLn "Error: some key events have the same keys bound to them."++ forM_ collisions $ \(b, hs) -> do+ Text.putStrLn $ "Handlers with the '" <> K.ppBinding b <> "' binding:"+ forM_ hs $ \h -> do+ let trigger = case K.kehEventTrigger $ K.khHandler h of+ K.ByKey k -> "triggered by the key '" <> K.ppBinding k <> "'"+ K.ByEvent e -> "triggered by the event '" <> fromJust (K.keyEventName allKeyEvents e) <> "'"+ desc = K.handlerDescription $ K.kehHandler $ K.khHandler h++ Text.putStrLn $ " " <> desc <> " (" <> trigger <> ")"++ exitFailure++ void $ M.defaultMain app $ St kc d (newFileMenu d) "(none yet)"
programs/MouseDemo.hs view
@@ -43,11 +43,15 @@ buttonLayer :: St -> Widget Name buttonLayer st =- C.vCenterLayer $- 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))+ C.centerLayer $+ hLimit 60 $+ vBox $+ C.hCenter <$>+ [ padBottom (Pad 1) $ str "Click a button:"+ , hBox $ padLeftRight 1 <$> buttons+ , padTopBottom 1 $ str "Or enter text and then click in this editor:"+ , vLimit 3 $ hLimit 50 $ E.renderEditor (str . unlines) True (st^.edit)+ ] where buttons = mkButton <$> buttonData buttonData = [ (Button1, "Button 1", attrName "button1")@@ -65,8 +69,8 @@ proseLayer :: St -> Widget Name proseLayer st =+ C.hCenter $ B.border $- C.hCenterLayer $ vLimit 8 $ viewport Prose Vertical $ vBox $ map str $ lines (st^.prose)@@ -80,7 +84,7 @@ "Click and hold/drag to report a mouse click" Just (name, T.Location l) -> "Mouse down at " <> show name <> " @ " <> show l- T.render $ translateBy (T.Location (0, h-1)) $ clickable Info $+ T.render $ translateLayer (T.Location (0, h-1)) $ clickable Info $ withDefAttr (attrName "info") $ C.hCenter $ str msg
programs/ProgressBarDemo.hs view
@@ -21,12 +21,13 @@ import Brick.Widgets.Core ( (<+>), (<=>) , str+ , strWrap , updateAttrMap , overrideAttr ) import Brick.Util (fg, bg, on, clamp) -data MyAppState n = MyAppState { _x, _y, _z :: Float }+data MyAppState n = MyAppState { _x, _y, _z :: Float, _showLabel :: Bool } makeLenses ''MyAppState @@ -48,13 +49,32 @@ zBar = overrideAttr P.progressCompleteAttr zDoneAttr $ overrideAttr P.progressIncompleteAttr zToDoAttr $ bar $ _z p- lbl c = Just $ show $ fromEnum $ c * 100+ -- custom bars+ cBar1 = overrideAttr P.progressCompleteAttr cDoneAttr1 $+ overrideAttr P.progressIncompleteAttr cToDoAttr1+ $ bar' '▰' '▱' $ _x p+ cBar2 = overrideAttr P.progressCompleteAttr cDoneAttr2 $+ overrideAttr P.progressIncompleteAttr cToDoAttr2+ $ bar' '|' '─' $ _y p+ cBar3 = overrideAttr P.progressCompleteAttr cDoneAttr $+ overrideAttr P.progressIncompleteAttr cToDoAttr+ $ bar' '⣿' '⠶' $ _z p+ lbl c = if _showLabel p+ then Just $ " " ++ (show $ fromEnum $ c * 100) ++ " "+ else Nothing bar v = P.progressBar (lbl v) v+ bar' cc ic v = P.customProgressBar cc ic (lbl v) v ui = (str "X: " <+> xBar) <=> (str "Y: " <+> yBar) <=> (str "Z: " <+> zBar) <=>+ (str "X: " <+> cBar1) <=>+ (str "Y: " <+> cBar2) <=>+ (str "Z: " <+> cBar3) <=> str "" <=>- str "Hit 'x', 'y', or 'z' to advance progress, or 'q' to quit"+ (strWrap $ concat [ "Hit 'x', 'y', or 'z' to advance progress,"+ , "'t' to toggle labels, 'r' to revert values, "+ , "'Ctrl + r' to reset values or 'q' to quit"+ ]) appEvent :: T.BrickEvent () e -> T.EventM () (MyAppState ()) () appEvent (T.VtyEvent e) =@@ -63,12 +83,18 @@ 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 't') [] -> showLabel %= not+ V.EvKey (V.KChar 'r') [V.MCtrl] -> do+ x .= 0+ y .= 0+ z .= 0+ V.EvKey (V.KChar 'r') [] -> T.put initialState V.EvKey (V.KChar 'q') [] -> M.halt _ -> return () appEvent _ = return () initialState :: MyAppState ()-initialState = MyAppState 0.25 0.18 0.63+initialState = MyAppState 0.25 0.18 0.63 True theBaseAttr :: A.AttrName theBaseAttr = A.attrName "theBase"@@ -85,6 +111,18 @@ zDoneAttr = theBaseAttr <> A.attrName "Z:done" zToDoAttr = theBaseAttr <> A.attrName "Z:remaining" +cDoneAttr, cToDoAttr :: A.AttrName+cDoneAttr = A.attrName "C:done"+cToDoAttr = A.attrName "C:remaining"++cDoneAttr1, cToDoAttr1 :: A.AttrName+cDoneAttr1 = A.attrName "C1:done"+cToDoAttr1 = A.attrName "C1:remaining"++cDoneAttr2, cToDoAttr2 :: A.AttrName+cDoneAttr2 = A.attrName "C2:done"+cToDoAttr2 = A.attrName "C2:remaining"+ theMap :: A.AttrMap theMap = A.attrMap V.defAttr [ (theBaseAttr, bg V.brightBlack)@@ -93,6 +131,12 @@ , (yDoneAttr, V.magenta `on` V.yellow) , (zDoneAttr, V.blue `on` V.green) , (zToDoAttr, V.blue `on` V.red)+ , (cDoneAttr, fg V.blue)+ , (cToDoAttr, fg V.blue)+ , (cDoneAttr1, fg V.red)+ , (cToDoAttr1, fg V.brightWhite)+ , (cDoneAttr2, fg V.green)+ , (cToDoAttr2, fg V.brightGreen) , (P.progressIncompleteAttr, fg V.yellow) ]
+ programs/TabularListDemo.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+module Main where++import Lens.Micro ((^.))+import Lens.Micro.Mtl+import Lens.Micro.TH+import Control.Monad (void)+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid+#endif+import qualified Graphics.Vty as V++import qualified Brick.Main as M+import qualified Brick.Types as T+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.List as L+import qualified Brick.Widgets.Center as C+import qualified Brick.Widgets.Table as Table+import qualified Brick.AttrMap as A+import qualified Data.Vector as Vec+import Brick.Types+ ( Widget+ )+import Brick.Widgets.Core+ ( (<=>)+ , str+ , vLimit+ , hLimit+ , vBox+ , hBox+ , withDefAttr+ )+import Brick.Util (on)++data Row = Row String String String++data AppState =+ AppState { _tabularList :: L.List () Row+ , _colIndex :: Int+ }++makeLenses ''AppState++drawUI :: AppState -> [Widget ()]+drawUI s = [ui]+ where+ l = s^.tabularList+ label = str $ "Row " <> cur <> " / col " <> show (s^.colIndex + 1)+ cur = case l^.(L.listSelectedL) of+ Nothing -> "-"+ Just i -> show (i + 1)+ box = B.borderWithLabel label $+ hLimit totalWidth $+ vLimit 15 $+ listDrawElement 0 False headerRow <=>+ L.renderList (listDrawElement (s^.colIndex)) True l+ ui = C.vCenter $ vBox [ C.hCenter box+ , str " "+ , C.hCenter $ str "Press +/- to add/remove list elements."+ , C.hCenter $ str "Use arrow keys to change selection."+ , C.hCenter $ str "Press Esc to exit."+ ]++appEvent :: T.BrickEvent () e -> T.EventM () AppState ()+appEvent (T.VtyEvent e) =+ case e of+ V.EvKey (V.KChar '+') [] -> do+ els <- use (tabularList.L.listElementsL)+ let el = Row (show pos) (show $ pos * 3) (show $ pos * 9)+ pos = Vec.length els+ tabularList %= L.listInsert pos el++ V.EvKey (V.KChar '-') [] -> do+ sel <- use (tabularList.L.listSelectedL)+ case sel of+ Nothing -> return ()+ Just i -> tabularList %= L.listRemove i++ V.EvKey V.KLeft [] ->+ colIndex %= (\i -> max 0 (i - 1))+ V.EvKey V.KRight [] ->+ colIndex %= (\i -> min (length columnAlignments - 1) (i + 1))++ V.EvKey V.KEsc [] -> M.halt++ ev -> T.zoom tabularList $ L.handleListEvent ev+appEvent _ = return ()++listDrawElement :: Int -> Bool -> Row -> Widget ()+listDrawElement colIdx sel (Row a b c) =+ let ws = [str a, str b, str c]+ maybeSelect es = selectCell <$> zip [0..] es+ selectCell (i, w) = if sel && i == colIdx+ then withDefAttr selectedCellAttr w+ else w+ in hLimit totalWidth $+ hBox $+ maybeSelect $+ Table.alignColumns columnAlignments columnWidths ws++initialState :: AppState+initialState =+ AppState { _tabularList = L.list () (Vec.fromList initialRows) 1+ , _colIndex = 0+ }++selectedCellAttr :: A.AttrName+selectedCellAttr = A.attrName "selectedCell"++theMap :: A.AttrMap+theMap = A.attrMap V.defAttr+ [ (L.listAttr, V.white `on` V.blue)+ , (selectedCellAttr, V.blue `on` V.white)+ ]++columnWidths :: [Int]+columnWidths = [10, 15, 20]++totalWidth :: Int+totalWidth = sum columnWidths++headerRow :: Row+headerRow = Row "Col 1" "Col 2" "Col 3"++columnAlignments :: [Table.ColumnAlignment]+columnAlignments = [Table.AlignLeft, Table.AlignCenter, Table.AlignRight]++initialRows :: [Row]+initialRows =+ [ Row "one" "two" "three"+ , Row "foo" "bar" "baz"+ , Row "stuff" "things" "blah"+ ]++theApp :: M.App AppState e ()+theApp =+ M.App { M.appDraw = drawUI+ , M.appChooseCursor = M.showFirstCursor+ , M.appHandleEvent = appEvent+ , M.appStartEvent = return ()+ , M.appAttrMap = const theMap+ }++main :: IO ()+main = void $ M.defaultMain theApp initialState
programs/TailDemo.hs view
@@ -142,11 +142,10 @@ main :: IO () main = do- cfg <- V.standardIOConfig- vty <- V.mkVty cfg chan <- newBChan 10 -- Run thread to simulate incoming data void $ forkIO $ generateLines chan - void $ customMain vty (V.mkVty cfg) (Just chan) app initialState+ (_, vty) <- customMainWithDefaultVty (Just chan) app initialState+ V.shutdown vty
programs/ThemeDemo.hs view
@@ -71,7 +71,7 @@ , 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+ -- to build an attribute map from a theme every time this is -- invoked, because it gets invoked once per redraw. Instead -- we'd build the attribute map at startup and store it in -- the application state. Here I just use themeToAttrMap to
programs/ViewportScrollbarsDemo.hs view
@@ -10,6 +10,7 @@ import Data.Monoid ((<>)) #endif import qualified Graphics.Vty as V+import Graphics.Vty.CrossPlatform (mkVty) import qualified Brick.Types as T import qualified Brick.Main as M@@ -41,24 +42,36 @@ , withVScrollBars , withHScrollBars , withHScrollBarRenderer+ , withVScrollBarRenderer , withVScrollBarHandles , withHScrollBarHandles , withClickableHScrollBars , withClickableVScrollBars- , ScrollbarRenderer(..)+ , VScrollbarRenderer(..)+ , HScrollbarRenderer(..) , scrollbarAttr , scrollbarHandleAttr ) -customScrollbars :: ScrollbarRenderer n-customScrollbars =- ScrollbarRenderer { renderScrollbar = fill '^'- , renderScrollbarTrough = fill ' '- , renderScrollbarHandleBefore = str "<<"- , renderScrollbarHandleAfter = str ">>"- }+customHScrollbars :: HScrollbarRenderer n+customHScrollbars =+ HScrollbarRenderer { renderHScrollbar = vLimit 1 $ fill '^'+ , renderHScrollbarTrough = vLimit 1 $ fill ' '+ , renderHScrollbarHandleBefore = str "<<"+ , renderHScrollbarHandleAfter = str ">>"+ , scrollbarHeightAllocation = 2+ } -data Name = VP1 | VP2 | SBClick T.ClickableScrollbarElement Name+customVScrollbars :: VScrollbarRenderer n+customVScrollbars =+ VScrollbarRenderer { renderVScrollbar = C.hCenter $ hLimit 1 $ fill '*'+ , renderVScrollbarTrough = fill ' '+ , renderVScrollbarHandleBefore = C.hCenter $ str "-^-"+ , renderVScrollbarHandleAfter = C.hCenter $ str "-v-"+ , scrollbarWidthAllocation = 5+ }++data Name = VP1 | VP2 | VP3 | SBClick T.ClickableScrollbarElement Name deriving (Ord, Show, Eq) data St = St { _lastClickedElement :: Maybe (T.ClickableScrollbarElement, Name) }@@ -68,28 +81,57 @@ drawUi :: St -> [Widget Name] drawUi st = [ui] where- ui = C.center $ hLimit 70 $ vLimit 21 $+ ui = C.center $ hLimit 80 $ vLimit 21 $ (vBox [ pair , C.hCenter (str "Last clicked scroll bar element:") , str $ show $ _lastClickedElement st ])- pair = hBox [ padRight (Pad 5) $+ pair = hBox [ padRight (Pad 2) $ B.border $ withClickableHScrollBars SBClick $ withHScrollBars OnBottom $- withHScrollBarRenderer customScrollbars $+ withHScrollBarRenderer customHScrollbars $ withHScrollBarHandles $ viewport VP1 Horizontal $ str $ "Press left and right arrow keys to scroll this viewport.\n" <> "This viewport uses a\n" <> "custom scroll bar renderer!"- , B.border $++ , padRight (Pad 2) $+ B.border $ withClickableVScrollBars SBClick $ withVScrollBars OnLeft $+ withVScrollBarRenderer customVScrollbars $ withVScrollBarHandles $ viewport VP2 Both $- vBox $ str "Press ctrl-arrow keys to scroll this viewport horizontally and vertically."+ vBox $+ (str $ unlines $+ [ "Press up and down"+ , "arrow keys to"+ , "scroll this"+ , "viewport."+ , "This viewport uses"+ , "a custom scroll"+ , "bar renderer."+ ]) : (str <$> [ "Line " <> show i | i <- [2..55::Int] ])++ , B.border $+ withClickableVScrollBars SBClick $+ withVScrollBars OnLeft $+ withVScrollBarHandles $+ viewport VP3 Both $+ vBox $+ (str $ unlines $+ [ "Press control-up and"+ , "control-down arrow"+ , "keys to scroll"+ , "this viewport."+ , "This viewport uses"+ , "the default scroll bar"+ , "renderer."+ ])+ : (str <$> [ "Line " <> show i | i <- [2..55::Int] ]) ] vp1Scroll :: M.ViewportScroll Name@@ -98,13 +140,19 @@ vp2Scroll :: M.ViewportScroll Name vp2Scroll = M.viewportScroll VP2 +vp3Scroll :: M.ViewportScroll Name+vp3Scroll = M.viewportScroll VP3+ 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.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.KEsc [])) = M.halt appEvent (T.MouseDown (SBClick el n) _ _ _) = do+ lastClickedElement .= Just (el, n) case n of VP1 -> do let vp = M.viewportScroll VP1@@ -122,10 +170,16 @@ T.SBTroughBefore -> M.vScrollBy vp (-10) T.SBTroughAfter -> M.vScrollBy vp 10 T.SBBar -> return ()+ VP3 -> do+ let vp = M.viewportScroll VP3+ case el of+ T.SBHandleBefore -> M.vScrollBy vp (-1)+ T.SBHandleAfter -> M.vScrollBy vp 1+ T.SBTroughBefore -> M.vScrollBy vp (-10)+ T.SBTroughAfter -> M.vScrollBy vp 10+ T.SBBar -> return () _ -> return ()-- lastClickedElement .= Just (el, n) appEvent _ = return () theme :: AttrMap@@ -147,7 +201,7 @@ main :: IO () main = do let buildVty = do- v <- V.mkVty =<< V.standardIOConfig+ v <- mkVty V.defaultConfig V.setMode (V.outputIface v) V.Mouse True return v
src/Brick.hs view
@@ -1,7 +1,7 @@ -- | This module is provided as a convenience to import the most -- important parts of the API all at once. If you are new to Brick and -- are looking to learn it, the best place to start is the--- [Brick User Guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst).+-- [Brick User Guide](https://github.com/jtdaugherty/brick/blob/main/docs/guide.rst). -- The README also has links to other learning resources. Unlike -- most Haskell libraries that only have API documentation, Brick -- is best learned by reading the User Guide and other materials and
+ src/Brick/Animation.hs view
@@ -0,0 +1,588 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+-- | This module provides some infrastructure for adding animations to+-- Brick applications. See @programs/AnimationDemo.hs@ for a complete+-- working example of this API.+--+-- At a high level, this works as follows:+--+-- This module provides a threaded animation manager that manages a set+-- of running animations. The application creates the manager and starts+-- animations, which automatically loop or run once, depending on their+-- configuration. Each animation has some state in the application's+-- state that is automatically managed by the animation manager using a+-- lens-based API. Whenever animations need to be redrawn, the animation+-- manager sends a custom event with a state update to the application,+-- which must be evaluated by the main event loop to update animation+-- states. Each animation is associated with a 'Clip' -- sequence of+-- frames -- which may be static or may be built from the application+-- state at rendering time.+--+-- To use this module:+--+-- * Use a custom event type @e@ in your 'Brick.Main.App' and give the+-- event type a constructor @EventM n s () -> e@ (where @s@ and+-- @n@ are those in @App s e n@). This will require the use of+-- 'Brick.Main.customMain' and will also require the creation of a+-- 'Brick.BChan.BChan' for custom events.+--+-- * Add an 'AnimationManager' field to the application state @s@.+--+-- * Create an 'AnimationManager' at startup with+-- 'startAnimationManager', providing the custom event constructor and+-- 'BChan' created above. Store the manager in the application state.+--+-- * For each animation you want to run at any given time, add a field+-- to the application state of type @Maybe (Animation s n)@,+-- initialized to 'Nothing'. A value of 'Nothing' indicates that the+-- animation is not running.+--+-- * Ensure that each animation state field in @s@ has a lens, usually+-- by using 'Lens.Micro.TH.makeLenses'.+--+-- * Start new animations in 'EventM' with 'startAnimation'; stop them+-- with 'stopAnimation'. Supply clips for new animations with+-- 'newClip', 'newClip_', and the clip transformation functions.+--+-- * Call 'renderAnimation' in 'Brick.Main.appDraw' for each animation in the+-- application state.+--+-- * If needed, stop the animation manager with 'stopAnimationManager'.+--+-- See 'AnimationManager' and the docs for the rest of this module for+-- details.+module Brick.Animation+ ( -- * Animation managers+ AnimationManager+ , startAnimationManager+ , stopAnimationManager+ , minTickTime++ -- * Animations+ , Animation+ , animationFrameIndex++ -- * Starting and stopping animations+ , RunMode(..)+ , startAnimation+ , stopAnimation++ -- * Rendering animations+ , renderAnimation++ -- * Creating clips+ , Clip+ , newClip+ , newClip_+ , clipLength++ -- * Transforming clips+ , pingPongClip+ , reverseClip+ )+where++import Control.Concurrent (threadDelay, forkIO, ThreadId, killThread, myThreadId)+import qualified Control.Concurrent.STM as STM+import Control.Monad (forever, when)+import Control.Monad.State.Strict+import Data.Foldable (foldrM)+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HM+import Data.Maybe (fromMaybe)+import qualified Data.Vector as V+import Lens.Micro ((^.), (%~), (.~), (&), Traversal', _Just)+import Lens.Micro.TH (makeLenses)+import Lens.Micro.Mtl++import Brick.BChan+import Brick.Types (EventM, Widget)+import qualified Brick.Animation.Clock as C++-- | A sequence of a animation frames.+newtype Clip s n = Clip (V.Vector (s -> Widget n))+ deriving (Semigroup)++-- | Get the number of frames in a clip.+clipLength :: Clip s n -> Int+clipLength (Clip fs) = V.length fs++-- | Build a clip.+--+-- Each frame in a clip is represented by a function from a state to a+-- 'Widget'. This allows applications to determine on a per-frame basis+-- what should be drawn in an animation based on application state, if+-- desired, in the same style as 'Brick.Main.appDraw'.+--+-- If the provided list is empty, this calls 'error'.+newClip :: [s -> Widget n] -> Clip s n+newClip [] = error "clip: got an empty list"+newClip fs = Clip $ V.fromList fs++-- | Like 'newClip' but for static frames.+newClip_ :: [Widget n] -> Clip s n+newClip_ ws = newClip $ const <$> ws++-- | Extend a clip so that when the end of the original clip is reached,+-- it continues in reverse order to create a loop.+--+-- For example, if this is given a clip with frames A, B, C, and D, then+-- this returns a clip with frames A, B, C, D, C, and B.+--+-- If the given clip contains less than two frames, this is equivalent+-- to 'id'.+pingPongClip :: Clip s n -> Clip s n+pingPongClip (Clip fs) | V.length fs >= 2 =+ Clip $ fs <> V.reverse (V.init $ V.tail fs)+pingPongClip c = c++-- | Reverse a clip.+reverseClip :: Clip s n -> Clip s n+reverseClip (Clip fs) = Clip $ V.reverse fs++data AnimationManagerRequest s n =+ Tick C.Time+ | StartAnimation (Clip s n) Integer RunMode (Traversal' s (Maybe (Animation s n)))+ -- ^ Clip, frame duration in milliseconds, run mode, updater+ | StopAnimation (Animation s n)+ | Shutdown++-- | The running mode for an animation.+data RunMode =+ Once+ -- ^ Run the animation once and then end+ | Loop+ -- ^ Run the animation in a loop forever+ deriving (Eq, Show, Ord)++newtype AnimationID = AnimationID Int+ deriving (Eq, Ord, Show, Hashable)++-- | The state of a running animation.+--+-- Put one of these (wrapped in 'Maybe') in your application state for+-- each animation that you'd like to run concurrently.+data Animation s n =+ Animation { animationFrameIndex :: Int+ -- ^ The animation's current frame index, provided for+ -- convenience. Applications won't need to access this in+ -- most situations; use 'renderAnimation' instead.+ , animationID :: AnimationID+ -- ^ The animation's internally-managed ID+ , animationClip :: Clip s n+ -- ^ The animation's clip+ }++-- | Render an animation.+renderAnimation :: (s -> Widget n)+ -- ^ The fallback function to use for drawing if the+ -- animation is not running+ -> s+ -- ^ The state to provide when rendering the animation's+ -- current frame+ -> Maybe (Animation s n)+ -- ^ The animation state itself+ -> Widget n+renderAnimation fallback input mAnim =+ draw input+ where+ draw = fromMaybe fallback $ do+ a <- mAnim+ let idx = animationFrameIndex a+ Clip fs = animationClip a+ fs V.!? idx++data AnimationState s n =+ AnimationState { _animationStateID :: AnimationID+ , _animationNumFrames :: Int+ , _animationCurrentFrame :: Int+ , _animationFrameMilliseconds :: Integer+ , _animationRunMode :: RunMode+ , animationFrameUpdater :: Traversal' s (Maybe (Animation s n))+ , _animationNextFrameTime :: C.Time+ }++makeLenses ''AnimationState++-- | A manager for animations. The type variables for this type are the+-- same as those for 'Brick.Main.App'.+--+-- This asynchronously manages a set of running animations, advancing+-- each one over time. When a running animation's current frame needs+-- to be changed, the manager sends an 'EventM' update for that+-- animation to the application's event loop to perform the update to+-- the animation in the application state. The manager will batch such+-- updates if more than one animation needs to be changed at a time.+--+-- The manager has a /tick duration/ in milliseconds which is the+-- resolution at which animations are checked to see if they should+-- be updated. Animations also have their own frame duration in+-- milliseconds. For example, if a manager has a tick duration of 50+-- milliseconds and is running an animation with a frame duration of 100+-- milliseconds, then the manager will advance that animation by one+-- frame every two ticks. On the other hand, if a manager has a tick+-- duration of 100 milliseconds and is running an animation with a frame+-- duration of 50 milliseconds, the manager will advance that animation+-- by two frames on each tick.+--+-- Animation managers are started with 'startAnimationManager' and+-- stopped with 'stopAnimationManager'.+--+-- Animations are started with 'startAnimation' and stopped with+-- 'stopAnimation'. Each animation must be associated with an+-- application state field accessible with a traversal given to+-- 'startAnimation'.+--+-- When an animation is started, every time it advances a frame, and+-- when it is ended, the manager communicates these changes to the+-- application by using the custom event constructor provided to+-- 'startAnimationManager'. The manager uses that to schedule a state+-- update which the application is responsible for evaluating. The state+-- updates are built from the traversals provided to 'startAnimation'.+--+-- The manager-updated 'Animation' values in the application state are+-- then drawn with 'renderAnimation'.+--+-- Animations in 'Loop' mode are run forever until stopped with+-- 'stopAnimation'; animations in 'Once' mode run once and are removed+-- from the application state (set to 'Nothing') when they finish. All+-- state updates to the application state are performed by the manager's+-- custom event mechanism; the application never needs to directly+-- modify the 'Animation' application state fields except to initialize+-- them to 'Nothing'.+--+-- There is nothing here to prevent an application from running multiple+-- managers, each at a different tick rate. That may have performance+-- consequences, though, due to the loss of batch efficiency in state+-- updates, so we recommend using only one manager per application at a+-- sufficiently short tick duration.+data AnimationManager s e n =+ AnimationManager { animationMgrRequestThreadId :: ThreadId+ , animationMgrTickThreadId :: ThreadId+ , animationMgrOutputChan :: BChan e+ , animationMgrInputChan :: STM.TChan (AnimationManagerRequest s n)+ , animationMgrEventConstructor :: EventM n s () -> e+ , animationMgrRunning :: STM.TVar Bool+ }++tickThreadBody :: Int+ -> STM.TChan (AnimationManagerRequest s n)+ -> IO ()+tickThreadBody tickMilliseconds outChan = do+ let nextTick = C.addOffset tickOffset+ tickOffset = C.offsetFromMs $ toInteger tickMilliseconds+ go targetTime = do+ now <- C.getTime+ STM.atomically $ STM.writeTChan outChan $ Tick now++ -- threadDelay does not guarantee that we will wake up on+ -- time; it only ensures that we won't wake up earlier than+ -- requested. Since we can therefore oversleep, instead of+ -- always sleeping for tickMilliseconds (which would cause+ -- us to drift off of schedule as delays accumulate) we+ -- determine sleep time by measuring the distance between+ -- now and the next scheduled tick. This is still unreliable+ -- as we can still oversleep, but it keeps the oversleeping+ -- under control over time. It means most ticks may be+ -- slightly late (about 1-2 milliseconds is common) but this+ -- will prevent that per-tick error from accumulating.+ let nextTickTime = nextTick targetTime+ sleepMs = fromInteger $+ C.offsetToMs $+ C.subtractTime nextTickTime now++ -- threadDelay works in microseconds.+ threadDelay $ sleepMs * 1000+ go nextTickTime++ go =<< C.getTime++setNextFrameTime :: C.Time -> AnimationState s n -> AnimationState s n+setNextFrameTime t a = a & animationNextFrameTime .~ t++data ManagerState s e n =+ ManagerState { _managerStateInChan :: STM.TChan (AnimationManagerRequest s n)+ , _managerStateOutChan :: BChan e+ , _managerStateEventBuilder :: EventM n s () -> e+ , _managerStateAnimations :: HM.HashMap AnimationID (AnimationState s n)+ , _managerStateIDVar :: STM.TVar AnimationID+ }++makeLenses ''ManagerState++animationManagerThreadBody :: STM.TChan (AnimationManagerRequest s n)+ -> BChan e+ -> (EventM n s () -> e)+ -> IO ()+animationManagerThreadBody inChan outChan mkEvent = do+ idVar <- STM.newTVarIO $ AnimationID 1+ let initial = ManagerState { _managerStateInChan = inChan+ , _managerStateOutChan = outChan+ , _managerStateEventBuilder = mkEvent+ , _managerStateAnimations = mempty+ , _managerStateIDVar = idVar+ }+ evalStateT runManager initial++type ManagerM s e n a = StateT (ManagerState s e n) IO a++getNextManagerRequest :: ManagerM s e n (AnimationManagerRequest s n)+getNextManagerRequest = do+ inChan <- use managerStateInChan+ liftIO $ STM.atomically $ STM.readTChan inChan++sendApplicationStateUpdate :: EventM n s () -> ManagerM s e n ()+sendApplicationStateUpdate act = do+ outChan <- use managerStateOutChan+ mkEvent <- use managerStateEventBuilder+ liftIO $ writeBChan outChan $ mkEvent act++removeAnimation :: AnimationID -> ManagerM s e n ()+removeAnimation aId =+ managerStateAnimations %= HM.delete aId++lookupAnimation :: AnimationID -> ManagerM s e n (Maybe (AnimationState s n))+lookupAnimation aId =+ HM.lookup aId <$> use managerStateAnimations++insertAnimation :: AnimationState s n -> ManagerM s e n ()+insertAnimation a =+ managerStateAnimations %= HM.insert (a^.animationStateID) a++getNextAnimationID :: ManagerM s e n AnimationID+getNextAnimationID = do+ var <- use managerStateIDVar+ liftIO $ STM.atomically $ do+ AnimationID i <- STM.readTVar var+ let next = AnimationID $ i + 1+ STM.writeTVar var next+ return $ AnimationID i++runManager :: ManagerM s e n ()+runManager = forever $ do+ getNextManagerRequest >>= handleManagerRequest++handleManagerRequest :: AnimationManagerRequest s n -> ManagerM s e n ()+handleManagerRequest (StartAnimation clip frameMs runMode updater) = do+ aId <- getNextAnimationID+ now <- liftIO C.getTime+ let next = C.addOffset frameOffset now+ frameOffset = C.offsetFromMs frameMs+ a = AnimationState { _animationStateID = aId+ , _animationNumFrames = clipLength clip+ , _animationCurrentFrame = 0+ , _animationFrameMilliseconds = frameMs+ , _animationRunMode = runMode+ , animationFrameUpdater = updater+ , _animationNextFrameTime = next+ }++ insertAnimation a+ sendApplicationStateUpdate $ updater .= Just (Animation { animationID = aId+ , animationFrameIndex = 0+ , animationClip = clip+ })+handleManagerRequest (StopAnimation a) = do+ let aId = animationID a+ mA <- lookupAnimation aId+ case mA of+ Nothing -> return ()+ Just aState -> do+ -- Remove the animation from the manager+ removeAnimation aId++ -- Set the current animation state in the application state+ -- to none+ sendApplicationStateUpdate $ clearStateAction aState+handleManagerRequest Shutdown = do+ as <- HM.elems <$> use managerStateAnimations++ let updater = sequence_ $ clearStateAction <$> as+ when (not $ null as) $ do+ sendApplicationStateUpdate updater++ liftIO $ myThreadId >>= killThread+handleManagerRequest (Tick tickTime) = do+ -- Check all animation states for frame advances+ -- based on the relationship between the tick time+ -- and each animation's next frame time+ mUpdateAct <- checkAnimations tickTime+ case mUpdateAct of+ Nothing -> return ()+ Just act -> sendApplicationStateUpdate act++clearStateAction :: AnimationState s n -> EventM n s ()+clearStateAction a = animationFrameUpdater a .= Nothing++frameUpdateAction :: AnimationState s n -> EventM n s ()+frameUpdateAction a =+ animationFrameUpdater a._Just %=+ (\an -> an { animationFrameIndex = a^.animationCurrentFrame })++updateAnimationState :: C.Time -> AnimationState s n -> AnimationState s n+updateAnimationState now a =+ let differenceMs = C.offsetToMs $+ C.subtractTime now (a^.animationNextFrameTime)+ numFrames = 1 + (differenceMs `div` (a^.animationFrameMilliseconds))+ newNextTime = C.addOffset (C.offsetFromMs $ numFrames * (a^.animationFrameMilliseconds))+ (a^.animationNextFrameTime)++ -- The new frame is obtained by advancing from the current frame by+ -- numFrames.+ in setNextFrameTime newNextTime $ advanceBy numFrames a++checkAnimations :: C.Time -> ManagerM s e n (Maybe (EventM n s ()))+checkAnimations now = do+ let go a updaters = do+ result <- checkAnimation now a+ return $ case result of+ Nothing -> updaters+ Just u -> u : updaters++ anims <- use managerStateAnimations+ updaters <- foldrM go [] anims++ case updaters of+ [] -> return Nothing+ _ -> return $ Just $ sequence_ updaters++-- For each active animation, check to see if the animation's next frame+-- time has passed. If it has, advance its frame counter as appropriate+-- and schedule its frame index to be updated in the application state.+checkAnimation :: C.Time -> AnimationState s n -> ManagerM s e n (Maybe (EventM n s ()))+checkAnimation now a+ | isFinished a = do+ -- This animation completed in a previous check, so clear it+ -- from the manager and the application state.+ removeAnimation (a^.animationStateID)+ return $ Just $ clearStateAction a+ | (now < a^.animationNextFrameTime) =+ -- This animation is not due for an update, so don't do+ -- anything.+ return Nothing+ | otherwise = do+ -- This animation is still running, so determine how many frames+ -- have elapsed for it and then advance the frame index based+ -- the elapsed time. Also set its next frame time.+ let a' = updateAnimationState now a+ managerStateAnimations %= HM.insert (a'^.animationStateID) a'+ return $ Just $ frameUpdateAction a'++isFinished :: AnimationState s n -> Bool+isFinished a =+ case a^.animationRunMode of+ Once -> a^.animationCurrentFrame == a^.animationNumFrames - 1+ Loop -> False++advanceBy :: Integer -> AnimationState s n -> AnimationState s n+advanceBy n a+ | n <= 0 = a+ | otherwise =+ advanceBy (n - 1) $+ advanceByOne a++advanceByOne :: AnimationState s n -> AnimationState s n+advanceByOne a =+ if a^.animationCurrentFrame == a^.animationNumFrames - 1+ then case a^.animationRunMode of+ Loop -> a & animationCurrentFrame .~ 0+ Once -> a+ else a & animationCurrentFrame %~ (+ 1)++-- | The minimum tick duration in milliseconds allowed by+-- 'startAnimationManager'.+minTickTime :: Int+minTickTime = 25++-- | Start a new animation manager. For full details about how managers+-- work, see 'AnimationManager'.+--+-- If the specified tick duration is less than 'minTickTime', this will+-- call 'error'. This bound is in place to prevent API misuse leading to+-- ticking so fast that the terminal can't keep up with redraws.+startAnimationManager :: (MonadIO m)+ => Int+ -- ^ The tick duration for this manager in milliseconds+ -> BChan e+ -- ^ The event channel to use to send updates to+ -- the application (i.e. the same one given to+ -- e.g. 'Brick.Main.customVty')+ -> (EventM n s () -> e)+ -- ^ A constructor for building custom events+ -- that perform application state updates. The+ -- application must evaluate these custom events'+ -- 'EventM' actions in order to record animation+ -- updates in the application state.+ -> m (AnimationManager s e n)+startAnimationManager tickMilliseconds _ _ | tickMilliseconds < minTickTime =+ error $ "startAnimationManager: tick duration too small (minimum is " <> show minTickTime <> ")"+startAnimationManager tickMilliseconds outChan mkEvent = liftIO $ do+ inChan <- STM.newTChanIO+ reqTid <- forkIO $ animationManagerThreadBody inChan outChan mkEvent+ tickTid <- forkIO $ tickThreadBody tickMilliseconds inChan+ runningVar <- STM.newTVarIO True+ return $ AnimationManager { animationMgrRequestThreadId = reqTid+ , animationMgrTickThreadId = tickTid+ , animationMgrEventConstructor = mkEvent+ , animationMgrOutputChan = outChan+ , animationMgrInputChan = inChan+ , animationMgrRunning = runningVar+ }++-- | Execute the specified action only when this manager is running.+whenRunning :: (MonadIO m) => AnimationManager s e n -> IO () -> m ()+whenRunning mgr act = do+ running <- liftIO $ STM.atomically $ STM.readTVar (animationMgrRunning mgr)+ when running $ liftIO act++-- | Stop the animation manager, ending all running animations.+stopAnimationManager :: (MonadIO m) => AnimationManager s e n -> m ()+stopAnimationManager mgr =+ whenRunning mgr $ do+ tellAnimationManager mgr Shutdown+ killThread $ animationMgrTickThreadId mgr+ STM.atomically $ STM.writeTVar (animationMgrRunning mgr) False++-- | Send a request to an animation manager.+tellAnimationManager :: (MonadIO m)+ => AnimationManager s e n+ -- ^ The manager+ -> AnimationManagerRequest s n+ -- ^ The request to send+ -> m ()+tellAnimationManager mgr req =+ liftIO $+ STM.atomically $+ STM.writeTChan (animationMgrInputChan mgr) req++-- | Start a new animation at its first frame.+--+-- This will result in an application state update to initialize the+-- animation state at the provided traversal's location.+startAnimation :: (MonadIO m)+ => AnimationManager s e n+ -- ^ The manager to run the animation+ -> Clip s n+ -- ^ The frames for the animation+ -> Integer+ -- ^ The animation's frame duration in milliseconds+ -> RunMode+ -- ^ The animation's run mode+ -> Traversal' s (Maybe (Animation s n))+ -- ^ Where in the application state to manage this+ -- animation's state+ -> m ()+startAnimation mgr frames frameMs runMode updater =+ tellAnimationManager mgr $ StartAnimation frames frameMs runMode updater++-- | Stop an animation.+--+-- This will result in an application state update to remove the+-- animation state.+stopAnimation :: (MonadIO m)+ => AnimationManager s e n+ -> Animation s n+ -> m ()+stopAnimation mgr a =+ tellAnimationManager mgr $ StopAnimation a
+ src/Brick/Animation/Clock.hs view
@@ -0,0 +1,64 @@+-- | This module provides an API for working with+-- 'Data.Time.Clock.System.SystemTime' values similar to that of+-- 'Data.Time.Clock.UTCTime'. @SystemTime@s are more efficient to+-- obtain than @UTCTime@s, which is important to avoid animation+-- tick thread delays associated with expensive clock reads. In+-- addition, the @UTCTime@-based API provides unpleasant @Float@-based+-- conversions. Since the @SystemTime@-based API doesn't provide some+-- of the operations we need, and since it is easier to work with at+-- millisecond granularity, it is extended here for internal use.+module Brick.Animation.Clock+ ( Time+ , getTime+ , addOffset+ , subtractTime++ , Offset+ , offsetFromMs+ , offsetToMs+ )+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Time.Clock.System as C++newtype Time = Time C.SystemTime+ deriving (Ord, Eq)++-- | Signed difference in milliseconds+newtype Offset = Offset Integer+ deriving (Ord, Eq)++offsetFromMs :: Integer -> Offset+offsetFromMs = Offset++offsetToMs :: Offset -> Integer+offsetToMs (Offset ms) = ms++getTime :: (MonadIO m) => m Time+getTime = Time <$> liftIO C.getSystemTime++addOffset :: Offset -> Time -> Time+addOffset (Offset ms) (Time (C.MkSystemTime s ns)) =+ Time $ C.MkSystemTime (fromInteger s') (fromInteger ns')+ where+ -- Note that due to the behavior of divMod, this works even when+ -- the offset is negative: the number of seconds is decremented+ -- and the remainder of nanoseconds is correct.+ s' = newSec + toInteger s+ (newSec, ns') = (nsPerMs * ms + toInteger ns)+ `divMod` (msPerS * nsPerMs)++subtractTime :: Time -> Time -> Offset+subtractTime t1 t2 = Offset $ timeToMs t1 - timeToMs t2++timeToMs :: Time -> Integer+timeToMs (Time (C.MkSystemTime s ns)) =+ (toInteger s) * msPerS ++ (toInteger ns) `div` nsPerMs++nsPerMs :: Integer+nsPerMs = 1000000++msPerS :: Integer+msPerS = 1000
src/Brick/AttrMap.hs view
@@ -27,6 +27,7 @@ -- * Construction , attrMap , forceAttrMap+ , forceAttrMapAllowStyle , attrName -- * Inspection , attrNameComponents@@ -78,6 +79,7 @@ -- | An attribute map which maps 'AttrName' values to 'Attr' values. data AttrMap = AttrMap Attr (M.Map AttrName Attr) | ForceAttr Attr+ | ForceAttrAllowStyle Attr AttrMap deriving (Show, Generic, NFData) -- | Create an attribute name from a string.@@ -103,6 +105,11 @@ forceAttrMap :: Attr -> AttrMap forceAttrMap = ForceAttr +-- | Create an attribute map in which all lookups map to the same+-- attribute. This is functionally equivalent to @attrMap attr []@.+forceAttrMapAllowStyle :: Attr -> AttrMap -> AttrMap+forceAttrMapAllowStyle = ForceAttrAllowStyle+ -- | Given an attribute and a map, merge the attribute with the map's -- default attribute. If the map is forcing all lookups to a specific -- attribute, the forced attribute is returned without merging it with@@ -122,6 +129,7 @@ -- @ mergeWithDefault :: Attr -> AttrMap -> Attr mergeWithDefault _ (ForceAttr a) = a+mergeWithDefault _ (ForceAttrAllowStyle f _) = f mergeWithDefault a (AttrMap d _) = combineAttrs d a -- | Look up the specified attribute name in the map. Map lookups@@ -148,6 +156,12 @@ -- @ attrMapLookup :: AttrName -> AttrMap -> Attr attrMapLookup _ (ForceAttr a) = a+attrMapLookup a (ForceAttrAllowStyle forced m) =+ -- Look up the attribute in the contained map, then keep only its+ -- style.+ let result = attrMapLookup a m+ in forced { attrStyle = attrStyle forced `combineStyles` attrStyle result+ } attrMapLookup (AttrName []) (AttrMap theDefault _) = theDefault attrMapLookup (AttrName ns) (AttrMap theDefault m) = let results = mapMaybe (\n -> M.lookup (AttrName n) m) (inits ns)@@ -156,11 +170,14 @@ -- | Set the default attribute value in an attribute map. setDefaultAttr :: Attr -> AttrMap -> AttrMap setDefaultAttr _ (ForceAttr a) = ForceAttr a+setDefaultAttr newDefault (ForceAttrAllowStyle a m) =+ ForceAttrAllowStyle a (setDefaultAttr newDefault m) setDefaultAttr newDefault (AttrMap _ m) = AttrMap newDefault m -- | Get the default attribute value in an attribute map. getDefaultAttr :: AttrMap -> Attr getDefaultAttr (ForceAttr a) = a+getDefaultAttr (ForceAttrAllowStyle _ m) = getDefaultAttr m getDefaultAttr (AttrMap d _) = d combineAttrs :: Attr -> Attr -> Attr@@ -185,6 +202,7 @@ applyAttrMappings :: [(AttrName, Attr)] -> AttrMap -> AttrMap applyAttrMappings _ (ForceAttr a) = ForceAttr a applyAttrMappings ms (AttrMap d m) = AttrMap d ((M.fromList ms) `M.union` m)+applyAttrMappings ms (ForceAttrAllowStyle a m) = ForceAttrAllowStyle a (applyAttrMappings ms m) -- | Update an attribute map such that a lookup of 'ontoName' returns -- the attribute value specified by 'fromName'. This is useful for
src/Brick/BorderMap.hs view
@@ -17,7 +17,9 @@ ) where import Brick.Types.Common (Edges(..), Location(..), eTopL, eBottomL, eRightL, eLeftL, origin)+#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative (liftA2)+#endif import Data.IMap (IMap, Run(Run)) import GHC.Generics import Control.DeepSeq
src/Brick/Focus.hs view
@@ -25,6 +25,7 @@ -- | A focus ring containing a sequence of resource names to focus and a -- currently-focused name. newtype FocusRing n = FocusRing (C.CList n)+ deriving (Show) -- | Construct a focus ring from the list of resource names. focusRing :: [n] -> FocusRing n
src/Brick/Forms.hs view
@@ -49,6 +49,7 @@ Form , FormFieldState(..) , FormField(..)+ , FormFieldVisibilityMode(..) -- * Creating and using forms , newForm@@ -65,6 +66,7 @@ , setFieldConcat , setFormFocus , updateFormState+ , setFieldVisibilityMode -- * Simple form field constructors , editTextField@@ -145,6 +147,21 @@ -- ^ An event handler for this field. } +-- | How to bring form fields into view when a form is rendered in a+-- viewport with 'viewport'.+data FormFieldVisibilityMode =+ ShowFocusedFieldOnly+ -- ^ Make only the focused field's selected input visible. For+ -- composite fields this will not bring all options into view.+ | ShowCompositeField+ -- ^ Make all inputs in the focused field visible. For composite+ -- fields this will bring all options into view as long as the+ -- viewport is large enough to show them all.+ | ShowAugmentedField+ -- ^ Like 'ShowCompositeField' but includes rendering augmentations+ -- applied with '@@='.+ deriving (Eq, Show)+ -- | A form field state accompanied by the fields that manipulate that -- state. The idea is that some record field in your form state has -- one or more form fields that manipulate that value. This data type@@ -189,6 +206,9 @@ , formFieldConcat :: [Widget n] -> Widget n -- ^ Concatenation function for this field's input -- renderings.+ , formFieldVisibilityMode :: FormFieldVisibilityMode+ -- ^ This field's visibility mode for use in+ -- viewports. } -> FormFieldState s e n -- | A form: a sequence of input fields that manipulate the fields of an@@ -250,8 +270,8 @@ updateFormState :: s -> Form s e n -> Form s e n updateFormState newState f = let updateField fs = case fs of- FormFieldState st l upd s rh concatAll ->- FormFieldState (upd (newState^.l) st) l upd s rh concatAll+ FormFieldState st l upd s rh concatAll visMode ->+ FormFieldState (upd (newState^.l) st) l upd s rh concatAll visMode in f { formState = newState , formFieldStates = updateField <$> formFieldStates f }@@ -287,7 +307,7 @@ } formFieldNames :: FormFieldState s e n -> [n]-formFieldNames (FormFieldState _ _ _ fields _ _) = formFieldName <$> fields+formFieldNames (FormFieldState _ _ _ fields _ _ _) = formFieldName <$> fields -- | A form field for manipulating a boolean value. This represents -- 'True' as @[X] label@ and 'False' as @[ ] label@.@@ -345,6 +365,7 @@ \val _ -> val , formFieldRenderHelper = id , formFieldConcat = vBox+ , formFieldVisibilityMode = ShowFocusedFieldOnly } renderCheckbox :: (Ord n) => Char -> Char -> Char -> T.Text -> n -> Bool -> Bool -> Widget n@@ -359,6 +380,9 @@ -- | A form field for selecting a single choice from a set of possible -- choices in a scrollable list. This uses a 'List' internally. --+-- This field's attributes are governed by those exported from+-- 'Brick.Widgets.List'.+-- -- This field responds to the same input events that a 'List' does. listField :: forall s e n a . (Ord n, Show n, Eq a) => (s -> Vector a)@@ -403,7 +427,9 @@ Just (_, e) -> listMoveToElement e l , formFieldRenderHelper = id , formFieldConcat = vBox+ , formFieldVisibilityMode = ShowFocusedFieldOnly }+ -- | A form field for selecting a single choice from a set of possible -- choices. Each choice has an associated value and text label. --@@ -471,6 +497,7 @@ , formFieldUpdate = \val _ -> val , formFieldRenderHelper = id , formFieldConcat = vBox+ , formFieldVisibilityMode = ShowFocusedFieldOnly } renderRadio :: (Eq a, Ord n) => Char -> Char -> Char -> a -> n -> T.Text -> Bool -> a -> Widget n@@ -492,6 +519,9 @@ -- a value. The other editing fields in this module are special cases of -- this function. --+-- This field's attributes are governed by those exported from+-- 'Brick.Widgets.Edit'.+-- -- This field responds to all events handled by 'editor', including -- mouse events. editField :: (Ord n, Show n)@@ -542,6 +572,7 @@ else applyEdit (Z.insertMany newTxt . Z.clearZipper) e , formFieldRenderHelper = id , formFieldConcat = vBox+ , formFieldVisibilityMode = ShowFocusedFieldOnly } -- | A form field using a single-line editor to edit the 'Show'@@ -550,6 +581,9 @@ -- useful in cases where the user-facing representation of a value -- matches the 'Show' representation exactly, such as with 'Int'. --+-- This field's attributes are governed by those exported from+-- 'Brick.Widgets.Edit'.+-- -- This field responds to all events handled by 'editor', including -- mouse events. editShowableField :: (Ord n, Show n, Read a, Show a)@@ -570,6 +604,9 @@ -- user-facing representation of a value matches the 'Show' representation -- exactly, such as with 'Int', but you don't want to accept just /any/ 'Int'. --+-- This field's attributes are governed by those exported from+-- 'Brick.Widgets.Edit'.+-- -- This field responds to all events handled by 'editor', including -- mouse events. editShowableFieldWithValidate :: (Ord n, Show n, Read a, Show a)@@ -598,6 +635,9 @@ -- | A form field using an editor to edit a text value. Since the value -- is free-form text, it is always valid. --+-- This field's attributes are governed by those exported from+-- 'Brick.Widgets.Edit'.+-- -- This field responds to all events handled by 'editor', including -- mouse events. editTextField :: (Ord n, Show n)@@ -620,6 +660,9 @@ -- value represented as a password. The value is always considered valid -- and is always represented with one asterisk per password character. --+-- This field's attributes are governed by those exported from+-- 'Brick.Widgets.Edit'.+-- -- This field responds to all events handled by 'editor', including -- mouse events. editPasswordField :: (Ord n, Show n)@@ -644,11 +687,18 @@ formAttr :: AttrName formAttr = attrName "brickForm" --- | The attribute for form input fields with invalid values.+-- | The attribute for form input fields with invalid values. Note that+-- this attribute will affect any field considered invalid and will take+-- priority over any attributes that the field uses to render itself. invalidFormInputAttr :: AttrName invalidFormInputAttr = formAttr <> attrName "invalidInput" --- | The attribute for form input fields that have the focus.+-- | The attribute for form input fields that have the focus. Note that+-- this attribute only affects fields that do not already use their own+-- attributes when rendering, such as editor- and list-based fields.+-- Those need to be styled by setting the appropriate attributes; see+-- the documentation for field constructors to find out which attributes+-- need to be configured. focusedFormInputAttr :: AttrName focusedFormInputAttr = formAttr <> attrName "focusedInput" @@ -666,6 +716,51 @@ invalidFields :: Form s e n -> [n] invalidFields f = concatMap getInvalidFields (formFieldStates f) +-- | Set the visibility mode of the specified form field's collection+-- when the form is rendered in viewport. This is used to change how+-- focused fields are brought into view when they're outside of view+-- in a viewport and gain focus. In practice, this means this function+-- need only be called on one form field name in a collection in order+-- to affect the visibility behavior of that field's entire input+-- collection.+--+-- There are two visibility modes:+--+-- * 'ShowFocusedFieldOnly' - this is the default behavior. In this+-- mode, when a field receives focus, it is brought into view but+-- other inputs in the same field collection (e.g. a set of radio+-- buttons) will not be brought into view along with it.+--+-- * 'ShowCompositeField' - in this mode, when a field receives focus,+-- all of the inputs in its collection (e.g. a set of radio buttons)+-- are brought into view as long as the viewport is large enough to+-- show them all. If it isn't, the viewport will show as many as space+-- allows.+--+-- * 'ShowAugmentedField' - in this mode, when a field receives focus,+-- all of the inputs in its collection (e.g. a set of radio buttons)+-- and its rendering augmentations (as applied with '@@=') are brought+-- into view as long as the viewport is large enough to show them all.+setFieldVisibilityMode :: (Eq n)+ => n+ -- ^ The name of the form field whose visibility mode is to be set.+ -> FormFieldVisibilityMode+ -- ^ The mode to set.+ -> Form s e n+ -- ^ The form to modify.+ -> Form s e n+setFieldVisibilityMode n mode form =+ let go1 [] = []+ go1 (s:ss) =+ let s' = case s of+ FormFieldState st l upd fs rh concatAll _ ->+ if n `elem` formFieldNames s+ then FormFieldState st l upd fs rh concatAll mode+ else s+ in s' : go1 ss++ in form { formFieldStates = go1 (formFieldStates form) }+ -- | Manually indicate that a field has invalid contents. This can be -- useful in situations where validation beyond the form element's -- validator needs to be performed and the result of that validation@@ -682,18 +777,18 @@ let go1 [] = [] go1 (s:ss) = let s' = case s of- FormFieldState st l upd fs rh concatAll ->+ FormFieldState st l upd fs rh concatAll visMode -> let go2 [] = [] go2 (f@(FormField fn val _ r h):ff) | n == fn = FormField fn val v r h : ff | otherwise = f : go2 ff- in FormFieldState st l upd (go2 fs) rh concatAll+ in FormFieldState st l upd (go2 fs) rh concatAll visMode in s' : go1 ss in form { formFieldStates = go1 (formFieldStates form) } getInvalidFields :: FormFieldState s e n -> [n]-getInvalidFields (FormFieldState st _ _ fs _ _) =+getInvalidFields (FormFieldState st _ _ fs _ _ _) = let gather (FormField n validate extValid _ _) = if not extValid || isNothing (validate st) then [n] else [] in concatMap gather fs@@ -710,7 +805,9 @@ -- 'invalidFormInputAttr' attribute. -- -- Finally, all of the resulting field renderings are concatenated with--- the form's concatenation function (see 'setFormConcat').+-- the form's concatenation function (see 'setFormConcat'). A visibility+-- request is also issued for the currently-focused form field in case+-- the form is rendered within a viewport. renderForm :: (Eq n) => Form s e n -> Widget n renderForm (Form es fr _ concatAll) = concatAll $ renderFormFieldState fr <$> es@@ -723,15 +820,24 @@ => FocusRing n -> FormFieldState s e n -> Widget n-renderFormFieldState fr (FormFieldState st _ _ fields helper concatFields) =- let renderFields [] = []+renderFormFieldState fr (FormFieldState st _ _ fields helper concatFields visMode) =+ let curFocus = focusGetCurrent fr+ foc = case curFocus of+ Nothing -> False+ Just n -> n `elem` fieldNames+ maybeVisible = if foc && visMode == ShowCompositeField then visible else id+ renderFields [] = [] renderFields ((FormField n validate extValid renderField _):fs) = let maybeInvalid = if (isJust $ validate st) && extValid then id else forceAttr invalidFormInputAttr- foc = Just n == focusGetCurrent fr- in maybeInvalid (renderField foc st) : renderFields fs- in helper $ concatFields $ renderFields fields+ fieldFoc = Just n == curFocus+ maybeFieldVisible = if fieldFoc && visMode == ShowFocusedFieldOnly then visible else id+ in (n, maybeFieldVisible $ maybeInvalid $ renderField fieldFoc st) : renderFields fs+ (fieldNames, renderedFields) = unzip $ renderFields fields+ maybeHelperVisible =+ if foc && visMode == ShowAugmentedField then visible else id+ in maybeHelperVisible $ helper $ maybeVisible $ concatFields renderedFields -- | Dispatch an event to the currently focused form field. This handles -- the following events in this order:@@ -807,7 +913,10 @@ i' = if i == 0 then length as - 1 else i - 1 in as !! i' -withFocusAndGrouping :: (Eq n) => BrickEvent n e -> (n -> [n] -> EventM n (Form s e n) ()) -> EventM n (Form s e n) ()+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@@ -834,7 +943,7 @@ let findFieldState _ [] = return () findFieldState prev (e:es) = case e of- FormFieldState st stLens upd fields helper concatAll -> do+ FormFieldState st stLens upd fields helper concatAll visMode -> do let findField [] = return Nothing findField (field:rest) = case field of@@ -851,7 +960,7 @@ case result of Nothing -> findFieldState (prev <> [e]) es Just (newSt, maybeSt) -> do- let newFieldState = FormFieldState newSt stLens upd fields helper concatAll+ let newFieldState = FormFieldState newSt stLens upd fields helper concatAll visMode formFieldStatesL .= prev <> [newFieldState] <> es case maybeSt of Nothing -> return ()
src/Brick/Keybindings/KeyConfig.hs view
@@ -47,6 +47,7 @@ import qualified Graphics.Vty as Vty import Brick.Keybindings.KeyEvents+import Brick.Keybindings.Normalize -- | A key binding. --@@ -67,10 +68,12 @@ -- ^ The set of modifiers. } deriving (Eq, Show, Ord) --- | Construct a 'Binding'. Modifier order is ignored.+-- | Construct a 'Binding'. Modifier order is ignored. If modifiers+-- are given and the binding is for a character key, it is forced to+-- lowercase. binding :: Vty.Key -> [Vty.Modifier] -> Binding binding k mods =- Binding { kbKey = k+ Binding { kbKey = normalizeKey mods k , kbMods = S.fromList mods } @@ -230,17 +233,23 @@ addModifier :: (ToBinding a) => Vty.Modifier -> a -> Binding addModifier m val = let b = bind val- in b { kbMods = S.insert m (kbMods b) }+ newMods = S.insert m $ kbMods b+ in b { kbMods = newMods+ , kbKey = normalizeKey (S.toList newMods) $ kbKey b+ } --- | Add Meta to a binding.+-- | Add Meta to a binding. If the binding is for a character key, force+-- it to lowercase. meta :: (ToBinding a) => a -> Binding meta = addModifier Vty.MMeta --- | Add Ctrl to a binding.+-- | Add Ctrl to a binding. If the binding is for a character key, force+-- it to lowercase. ctrl :: (ToBinding a) => a -> Binding ctrl = addModifier Vty.MCtrl --- | Add Shift to a binding.+-- | Add Shift to a binding. If the binding is for a character key, force+-- it to lowercase. shift :: (ToBinding a) => a -> Binding shift = addModifier Vty.MShift
src/Brick/Keybindings/KeyDispatcher.hs view
@@ -45,10 +45,13 @@ -- * Misc , keyDispatcherToList , lookupVtyEvent+ , lookupEvent+ , bindingsForEvent ) where import qualified Data.Map.Strict as M+import Data.Maybe (listToMaybe) import qualified Data.Set as S import qualified Data.Text as T import qualified Graphics.Vty as Vty@@ -106,6 +109,18 @@ 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 +-- | Find the handler that matches an abstract key event, if any.+lookupEvent :: (Eq k) => k -> KeyDispatcher k m -> Maybe (KeyHandler k m)+lookupEvent ev (KeyDispatcher m) = listToMaybe results+ where+ results = filter ((== ByEvent ev) . kehEventTrigger . khHandler) $ M.elems m++-- | Get the list of all key bindings for the specified event from this+-- dispatcher.+bindingsForEvent :: (Eq k) => KeyDispatcher k m -> k -> [Binding]+bindingsForEvent kd ev =+ [ b | KeyHandler { khBinding = b, khHandler = h } <- snd <$> keyDispatcherToList kd, kehEventTrigger h == ByEvent ev ]+ -- | 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@@ -151,9 +166,8 @@ groups = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) pairs badGroups = filter ((> 1) . length) groups combine :: [(Binding, KeyHandler k m)] -> (Binding, [KeyHandler k m])- combine as =- let b = fst $ head as- in (b, snd <$> as)+ combine as@((b, _):_) = (b, snd <$> as)+ combine _ = error "BUG: combine should only be called with non-empty lists" in if null badGroups then Right $ KeyDispatcher $ M.fromList pairs else Left $ combine <$> badGroups
+ src/Brick/Keybindings/Normalize.hs view
@@ -0,0 +1,14 @@+module Brick.Keybindings.Normalize+ ( normalizeKey+ )+where++import Data.Char (toLower)+import qualified Graphics.Vty as Vty++-- | A keybinding involving modifiers should have its key character+-- normalized to lowercase since it's impossible to get uppercase keys+-- from the terminal when modifiers are present.+normalizeKey :: [Vty.Modifier] -> Vty.Key -> Vty.Key+normalizeKey (_:_) (Vty.KChar c) = Vty.KChar $ toLower c+normalizeKey _ k = k
src/Brick/Keybindings/Parse.hs view
@@ -5,6 +5,7 @@ module Brick.Keybindings.Parse ( parseBinding , parseBindingList+ , normalizeKey , keybindingsFromIni , keybindingsFromFile@@ -14,7 +15,6 @@ 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@@ -23,6 +23,7 @@ import Brick.Keybindings.KeyEvents import Brick.Keybindings.KeyConfig+import Brick.Keybindings.Normalize -- | Parse a key binding list into a 'BindingState'. --@@ -83,7 +84,7 @@ parseBinding s = go (T.splitOn "-" $ T.toLower s) [] where go [k] mods = do k' <- pKey k- return Binding { kbMods = S.fromList mods, kbKey = k' }+ return $ binding k' mods go (k:ks) mods = do m <- case k of "s" -> return Vty.MShift
src/Brick/Keybindings/Pretty.hs view
@@ -25,7 +25,6 @@ import Brick import Data.List (sort, intersperse)-import Data.Maybe (fromJust) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif@@ -124,19 +123,19 @@ ByKey b -> (Comment "(non-customizable key)", [Verbatim $ ppBinding b]) ByEvent ev ->- let name = fromJust $ keyEventName (keyConfigEvents kc) ev+ let name = maybe (Comment "(unnamed)") Verbatim $ 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)+ then (name, Verbatim <$> ppBinding <$> allDefaultBindings kc ev)+ else (name, unbound) Just Unbound ->- (Verbatim name, unbound)+ (name, unbound) Just (BindingList bs) -> let result = if not (null bs) then Verbatim <$> ppBinding <$> bs else unbound- in (Verbatim name, result)+ in (name, result) in (label, handlerDescription $ kehHandler h, evText) -- | Build a 'Widget' displaying key binding information for a single@@ -164,8 +163,8 @@ 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+ Comment s -> txt s+ Verbatim s -> txt s in vBox [ withDefAttr eventDescriptionAttr $ txt desc , label <+> txt " = " <+> withDefAttr keybindingAttr (txt evText) ]
src/Brick/Main.hs view
@@ -5,6 +5,7 @@ , defaultMain , customMain , customMainWithVty+ , customMainWithDefaultVty , simpleMain , resizeOrQuit , simpleApp@@ -54,6 +55,7 @@ import qualified Control.Exception as E import Lens.Micro ((^.), (&), (.~), (%~), _1, _2)+import Control.Monad import Control.Monad.State.Strict import Control.Monad.Reader import Control.Concurrent (forkIO, killThread)@@ -72,11 +74,11 @@ , displayBounds , shutdown , nextEvent- , mkVty- , defaultConfig , restoreInputState , inputIface )+import Graphics.Vty.CrossPlatform (mkVty)+import Graphics.Vty.Config (defaultConfig) import Graphics.Vty.Attributes (defAttr) import Brick.BChan (BChan, newBChan, readBChan, readBChan2, writeBChan)@@ -121,8 +123,8 @@ } -- | The default main entry point which takes an application and an--- initial state and returns the final state returned by a 'halt'--- operation.+-- initial state and returns the final state from 'EventM' once the+-- program exits. defaultMain :: (Ord n) => App s e n -- ^ The application.@@ -130,9 +132,9 @@ -- ^ The initial application state. -> IO s defaultMain app st = do- let builder = mkVty defaultConfig- initialVty <- builder- customMain initialVty builder Nothing app st+ (s, vty) <- customMainWithDefaultVty Nothing app st+ shutdown vty+ return s -- | A simple main entry point which takes a widget and renders it. This -- event loop terminates when the user presses any key, but terminal@@ -234,6 +236,29 @@ restoreInitialState return s +-- | Like 'customMainWithVty', except that Vty is initialized with the+-- default configuration.+--+-- The returned 'Vty' handle still has control of the terminal. The+-- caller is responsible for calling 'shutdown' to restore the terminal+-- state.+customMainWithDefaultVty :: (Ord n)+ => Maybe (BChan e)+ -- ^ An event channel for sending custom+ -- events to the event loop (you write to this+ -- channel, the event loop reads from it).+ -- Provide 'Nothing' if you don't plan on+ -- sending custom events.+ -> App s e n+ -- ^ The application.+ -> s+ -- ^ The initial application state.+ -> IO (s, Vty)+customMainWithDefaultVty mUserChan app initialAppState = do+ let builder = mkVty defaultConfig+ vty <- builder+ customMainWithVty vty builder mUserChan app initialAppState+ -- | Like 'customMain', except the last 'Vty' handle used by the -- application is returned without being shut down with 'shutdown'. This -- allows the caller to re-use the 'Vty' handle for something else, such@@ -274,7 +299,7 @@ , rsScrollRequests = esScrollRequests eState , observedNames = S.empty , renderCache = mempty- , clickableNames = []+ , clickableNames = mempty , requestedVisibleNames_ = requestedVisibleNames eState , reportedExtents = mempty }@@ -323,9 +348,9 @@ -> App s e n -> s -> RenderState n- -> [Extent n]+ -> [LayerExtents n] -> Bool- -> IO (s, NextAction, RenderState n, [Extent n], VtyContext)+ -> IO (s, NextAction, RenderState n, [LayerExtents n], VtyContext) runVty vtyCtx readEvent app appState rs prevExtents draw = do (firstRS, exts) <- if draw then renderApp vtyCtx app appState rs@@ -435,14 +460,25 @@ -- | Did the specified mouse coordinates (column, row) intersect the -- specified extent? clickedExtent :: (Int, Int) -> Extent n -> Bool-clickedExtent (c, r) (Extent _ (Location (lc, lr)) (w, h)) =+clickedExtent pos (Extent _ ul sz) = clickedRegion pos ul sz++-- | Given a position and layer extent, return whether the position+-- falls within the layer extent.+clickedLayerExtent :: (Int, Int) -> LayerExtents n -> Bool+clickedLayerExtent pos (LayerExtents ul sz _) = clickedRegion pos ul sz++-- | Given a position, an upper-left corner, and a region size, return+-- whether the position falls within the region with the specified size+-- at the specified upper-left corner.+clickedRegion :: (Int, Int) -> Location -> (Int, Int) -> Bool+clickedRegion (c, r) (Location (lc, lr)) (w, h) = c >= lc && c < (lc + w) && r >= lr && r < (lr + h) -- | Given a resource name, get the most recent rendering extent for the -- name (if any). lookupExtent :: (Eq n) => n -> EventM n s (Maybe (Extent n))-lookupExtent n = EventM $ asks (find f . latestExtents)+lookupExtent n = EventM $ asks (find f . concat . fmap layerAppExtents . latestExtents) where f (Extent n' _ _) = n == n' @@ -451,12 +487,33 @@ -- 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].+--+-- Note that this will prohibit clicks from matching underlying layers+-- if the clicks intersect a layer even if that point in the layer is+-- not itself within a clickable region. This behavior ensures that any+-- clickable region is only clickable if it is not visually obscured by+-- another layer. 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)+-- Internal mouse click extent matching: assuming extents are in order+-- from upper to lower (in layer order), find all matching extents until+-- a layer base is reached, then stop. This ensures that a click on a+-- layer with no matching extent at that location will not fall through+-- to a matching extent at a lower (but visually obstructed) layer.+findClickedExtents_ :: (Int, Int) -> [LayerExtents n] -> [Extent n]+findClickedExtents_ pos ls =+ maybe [] fst $ find isMatch $ getMatching <$> ls+ where+ -- A layer is a match -- that is, it has been clicked on -- if+ -- either some application extent(s) were clicked, or if the+ -- layer itself was clicked outside of any declared extents+ isMatch (es, l) = not (null es) || clickedLayerExtent pos l + -- For a given layer, pair the layer with all of the clicked+ -- extents in that layer+ getMatching l = (reverse $ filter (clickedExtent pos) $ layerAppExtents l, l)+ -- | Get the Vty handle currently in use. getVtyHandle :: EventM n s Vty getVtyHandle = vtyContextHandle <$> getVtyContext@@ -479,12 +536,12 @@ getRenderState :: EventM n s (RenderState n) getRenderState = EventM $ asks oldState -resetRenderState :: RenderState n -> RenderState n+resetRenderState :: (Ord n) => RenderState n -> RenderState n resetRenderState s = s & observedNamesL .~ S.empty & clickableNamesL .~ mempty -renderApp :: (Ord n) => VtyContext -> App s e n -> s -> RenderState n -> IO (RenderState n, [Extent n])+renderApp :: (Ord n) => VtyContext -> App s e n -> s -> RenderState n -> IO (RenderState n, [LayerExtents n]) renderApp vtyCtx app appState rs = do sz <- displayBounds $ outputIface $ vtyContextHandle vtyCtx let (newRS, pic, theCursor, exts) = renderFinal (appAttrMap app appState)
src/Brick/Themes.hs view
@@ -6,8 +6,6 @@ -- | Support for representing attribute themes and loading and saving -- theme customizations in INI-style files. ----- The file format is as follows:--- -- Customization files are INI-style files with two sections, both -- optional: @"default"@ and @"other"@. --
src/Brick/Types.hs view
@@ -1,6 +1,5 @@ -- | Basic types used by this library. {-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module Brick.Types ( -- * The Widget type Widget(..)@@ -22,7 +21,8 @@ , vpContentSize , VScrollBarOrientation(..) , HScrollBarOrientation(..)- , ScrollbarRenderer(..)+ , VScrollbarRenderer(..)+ , HScrollbarRenderer(..) , ClickableScrollbarElement(..) -- * Event-handling types and functions@@ -97,7 +97,7 @@ ) where -import Lens.Micro (_1, _2, to, (^.))+import Lens.Micro (to, (^.)) import Lens.Micro.Type (Getting) import Lens.Micro.Mtl (zoom) #if !MIN_VERSION_base(4,13,0)@@ -153,12 +153,6 @@ -- | The rendering context's current drawing attribute. attrL :: forall r n. Getting r (Context n) Attr attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL))--instance TerminalLocation (CursorLocation n) where- locationColumnL = cursorLocationL._1- locationColumn = locationColumn . cursorLocation- locationRowL = cursorLocationL._2- locationRow = locationRow . cursorLocation -- | Given an attribute name, obtain the attribute for the attribute -- name by consulting the context's attribute map.
src/Brick/Types/Common.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE CPP #-} module Brick.Types.Common ( Location(..) , locL@@ -16,13 +17,17 @@ import GHC.Generics import Control.DeepSeq import Lens.Micro (_1, _2)+#if MIN_VERSION_microlens(0,5,0)+import Lens.Micro.FieldN (Field1, Field2)+#else import Lens.Micro.Internal (Field1, Field2)+#endif -- | A terminal screen location.-data Location = Location { loc :: (Int, Int)- -- ^ (Column, Row)- }- deriving (Show, Eq, Ord, Read, Generic, NFData)+newtype Location = Location { loc :: (Int, Int)+ -- ^ (Column, Row)+ }+ deriving (Show, Eq, Ord, Read, Generic, NFData) suffixLenses ''Location @@ -43,7 +48,7 @@ mempty = origin mappend = (Sem.<>) -data Edges a = Edges { eTop, eBottom, eLeft, eRight :: a }+data Edges a = Edges { eTop, eBottom, eLeft, eRight :: !a } deriving (Eq, Ord, Read, Show, Functor, Generic, NFData) suffixLenses ''Edges
src/Brick/Types/Internal.hs view
@@ -12,6 +12,7 @@ , locL , origin , TerminalLocation(..)+ , ClampPolicy(..) , Viewport(..) , ViewportType(..) , RenderState(..)@@ -20,12 +21,15 @@ , cursorLocationL , cursorLocationNameL , cursorLocationVisibleL+ , clOffset , VScrollBarOrientation(..) , HScrollBarOrientation(..)- , ScrollbarRenderer(..)+ , VScrollbarRenderer(..)+ , HScrollbarRenderer(..) , ClickableScrollbarElement(..) , Context(..) , ctxAttrMapL+ , ctxOrigAttrMapL , ctxAttrNameL , ctxBorderStyleL , ctxDynBordersL@@ -49,7 +53,10 @@ , EventRO(..) , NextAction(..) , Result(..)+ , addResultOffset+ , addTranslationOffset , Extent(..)+ , LayerExtents(..) , Edges(..) , eTopL, eBottomL, eRightL, eLeftL , BorderSegment(..)@@ -78,6 +85,10 @@ , cursorsL , extentsL , bordersL+ , translationOffsetL+ , verticalClampPolicyL+ , horizontalClampPolicyL+ , extraLayersL , visibilityRequestsL , emptyResult )@@ -86,7 +97,8 @@ import Control.Concurrent (ThreadId) import Control.Monad.Reader import Control.Monad.State.Strict-import Lens.Micro (_1, _2, Lens')+import Data.Sequence (Seq)+import Lens.Micro ((&), (%~), (^.), _1, _2, Lens', each) import Lens.Micro.Mtl (use) import Lens.Micro.TH (makeLenses) import qualified Data.Set as S@@ -102,16 +114,16 @@ import Brick.AttrMap (AttrName, AttrMap) import Brick.Widgets.Border.Style (BorderStyle) -data ScrollRequest = HScrollBy Int- | HScrollPage Direction+data ScrollRequest = HScrollBy !Int+ | HScrollPage !Direction | HScrollToBeginning | HScrollToEnd- | VScrollBy Int- | VScrollPage Direction+ | VScrollBy !Int+ | VScrollPage !Direction | VScrollToBeginning | VScrollToEnd- | SetTop Int- | SetLeft Int+ | SetTop !Int+ | SetLeft !Int deriving (Read, Show, Generic, NFData) -- | Widget size policies. These policies communicate how a widget uses@@ -130,9 +142,9 @@ -- | The type of widgets. data Widget n =- Widget { hSize :: Size+ Widget { hSize :: !Size -- ^ This widget's horizontal growth policy- , vSize :: Size+ , vSize :: !Size -- ^ This widget's vertical growth policy , render :: RenderM n (Result n) -- ^ This widget's rendering function@@ -142,8 +154,8 @@ RS { viewportMap :: !(M.Map n Viewport) , rsScrollRequests :: ![(n, ScrollRequest)] , observedNames :: !(S.Set n)- , renderCache :: !(M.Map n ([n], Result n))- , clickableNames :: ![n]+ , renderCache :: !(M.Map n (S.Set n, Result n))+ , clickableNames :: !(S.Set n) , requestedVisibleNames_ :: !(S.Set n) , reportedExtents :: !(M.Map n (Extent n)) } deriving (Read, Show, Generic, NFData)@@ -165,50 +177,85 @@ data HScrollBarOrientation = OnBottom | OnTop deriving (Show, Eq) --- | A scroll bar renderer.-data ScrollbarRenderer n =- ScrollbarRenderer { renderScrollbar :: Widget n- -- ^ How to render the body of the scroll bar.- -- This should provide a widget that expands in- -- whatever direction(s) this renderer will be- -- used for. So, for example, if this was used to- -- render vertical scroll bars, this widget would- -- need to be one that expands vertically such as- -- @fill@. The same goes for the trough widget.- , renderScrollbarTrough :: Widget n- -- ^ How to render the "trough" of the scroll bar- -- (the area to either side of the scroll bar- -- body). This should expand as described in the- -- documentation for the scroll bar field.- , renderScrollbarHandleBefore :: Widget n- -- ^ How to render the handle that appears at the- -- top or left of the scrollbar. The result should- -- be at most one row high for horizontal handles- -- and one column wide for vertical handles.- , renderScrollbarHandleAfter :: Widget n- -- ^ How to render the handle that appears at- -- the bottom or right of the scrollbar. The- -- result should be at most one row high for- -- horizontal handles and one column wide for- -- vertical handles.- }+-- | A vertical scroll bar renderer.+data VScrollbarRenderer n =+ VScrollbarRenderer { renderVScrollbar :: Widget n+ -- ^ How to render the body of the scroll bar.+ -- This should provide a widget that expands in+ -- whatever direction(s) this renderer will be+ -- used for. So, for example, this widget would+ -- need to be one that expands vertically such as+ -- @fill@. The same goes for the trough widget.+ , renderVScrollbarTrough :: Widget n+ -- ^ How to render the "trough" of the scroll bar+ -- (the area to either side of the scroll bar+ -- body). This should expand as described in the+ -- documentation for the scroll bar field.+ , renderVScrollbarHandleBefore :: Widget n+ -- ^ How to render the handle that appears at+ -- the top or left of the scrollbar. The result+ -- will be allowed to be at most one row high.+ , renderVScrollbarHandleAfter :: Widget n+ -- ^ How to render the handle that appears at the+ -- bottom or right of the scrollbar. The result+ -- will be allowed to be at most one row high.+ , scrollbarWidthAllocation :: Int+ -- ^ The number of columns that will be allocated+ -- to the scroll bar. This determines how much+ -- space the widgets of the scroll bar elements+ -- can take up. If they use less than this+ -- amount, padding will be applied between the+ -- scroll bar and the viewport contents.+ } +-- | A horizontal scroll bar renderer.+data HScrollbarRenderer n =+ HScrollbarRenderer { renderHScrollbar :: Widget n+ -- ^ How to render the body of the scroll bar.+ -- This should provide a widget that expands+ -- in whatever direction(s) this renderer will+ -- be used for. So, for example, this widget+ -- would need to be one that expands horizontally+ -- such as @fill@. The same goes for the trough+ -- widget.+ , renderHScrollbarTrough :: Widget n+ -- ^ How to render the "trough" of the scroll bar+ -- (the area to either side of the scroll bar+ -- body). This should expand as described in the+ -- documentation for the scroll bar field.+ , renderHScrollbarHandleBefore :: Widget n+ -- ^ How to render the handle that appears at the+ -- top or left of the scrollbar. The result will+ -- be allowed to be at most one column wide.+ , renderHScrollbarHandleAfter :: Widget n+ -- ^ How to render the handle that appears at the+ -- bottom or right of the scrollbar. The result+ -- will be allowed to be at most one column wide.+ , scrollbarHeightAllocation :: Int+ -- ^ The number of rows that will be allocated to+ -- the scroll bar. This determines how much space+ -- the widgets of the scroll bar elements can+ -- take up. If they use less than this amount,+ -- padding will be applied between the scroll bar+ -- and the viewport contents.+ }+ data VisibilityRequest =- VR { vrPosition :: Location- , vrSize :: DisplayRegion+ VR { vrPosition :: !Location+ , vrSize :: !DisplayRegion } deriving (Show, Eq, Read, Generic, NFData) -- | Describes the state of a viewport as it appears as its most recent -- rendering. data Viewport =- VP { _vpLeft :: Int+ VP { _vpLeft :: !Int -- ^ The column offset of left side of the viewport.- , _vpTop :: Int+ , _vpTop :: !Int -- ^ The row offset of the top of the viewport.- , _vpSize :: DisplayRegion+ , _vpSize :: !DisplayRegion -- ^ The size of the viewport.- , _vpContentSize :: DisplayRegion+ , _vpContentSize :: !DisplayRegion -- ^ The size of the contents of the viewport. } deriving (Show, Read, Generic, NFData)@@ -238,9 +285,9 @@ } data VtyContext =- VtyContext { vtyContextBuilder :: IO Vty- , vtyContextHandle :: Vty- , vtyContextThread :: ThreadId+ VtyContext { vtyContextBuilder :: !(IO Vty)+ , vtyContextHandle :: !Vty+ , vtyContextThread :: !ThreadId , vtyContextPutEvent :: Event -> IO () } @@ -251,6 +298,12 @@ } deriving (Show, Read, Generic, NFData) +data LayerExtents n =+ LayerExtents { layerExtentUpperLeft :: !Location+ , layerExtentSize :: !(Int, Int)+ , layerAppExtents :: ![Extent n]+ }+ -- | The type of actions to take upon completion of an event handler. data NextAction = Continue@@ -294,29 +347,32 @@ -- | A border character has four segments, one extending in each direction -- (horizontally and vertically) from the center of the character. data BorderSegment = BorderSegment- { bsAccept :: Bool+ { bsAccept :: !Bool -- ^ Would this segment be willing to be drawn if a neighbor wanted to -- connect to it?- , bsOffer :: Bool+ , bsOffer :: !Bool -- ^ Does this segment want to connect to its neighbor?- , bsDraw :: Bool+ , bsDraw :: !Bool -- ^ Should this segment be represented visually? } deriving (Eq, Ord, Read, Show, Generic, NFData) -- | Information about how to redraw a dynamic border character when it abuts -- another dynamic border character. data DynBorder = DynBorder- { dbStyle :: BorderStyle+ { dbStyle :: !BorderStyle -- ^ The 'Char's to use when redrawing the border. Also used to filter -- connections: only dynamic borders with equal 'BorderStyle's will connect -- to each other.- , dbAttr :: Attr+ , dbAttr :: !Attr -- ^ What 'Attr' to use to redraw the border character. Also used to filter -- connections: only dynamic borders with equal 'Attr's will connect to -- each other.- , dbSegments :: Edges BorderSegment+ , dbSegments :: !(Edges BorderSegment) } deriving (Eq, Read, Show, Generic, NFData) +data ClampPolicy = Truncate | Reposition+ deriving (Show, Read, Generic, NFData)+ -- | The type of result returned by a widget's rendering function. The -- result provides the image, cursor positions, and visibility requests -- that resulted from the rendering process.@@ -345,6 +401,18 @@ , borders :: !(BorderMap DynBorder) -- ^ Places where we may rewrite the edge of the image when -- placing this widget next to another one.+ , translationOffset :: !Location+ -- ^ Offset of this result's upper-left corner as a+ -- consequence of translation+ , horizontalClampPolicy :: !ClampPolicy+ -- ^ The policy for whether to clamp this layer to the screen+ -- horizontally, or let it get truncated+ , verticalClampPolicy :: !ClampPolicy+ -- ^ The policy for whether to clamp this layer to the screen+ -- vertically, or let it get truncated+ , extraLayers :: !(Seq (Result n))+ -- ^ Rendering results introduced as intermediate layers+ -- by this result } deriving (Show, Read, Generic, NFData) @@ -355,26 +423,30 @@ , visibilityRequests = [] , extents = [] , borders = BM.empty+ , translationOffset = Location (0, 0)+ , extraLayers = mempty+ , horizontalClampPolicy = Truncate+ , verticalClampPolicy = Truncate } -- | The type of events.-data BrickEvent n e = VtyEvent Event+data BrickEvent n e = VtyEvent !Event -- ^ The event was a Vty event.- | AppEvent e+ | AppEvent !e -- ^ The event was an application event.- | MouseDown n Button [Modifier] Location+ | MouseDown !n !Button ![Modifier] !Location -- ^ A mouse-down event on the specified region was -- received. The 'n' value is the resource name of -- the clicked widget (see 'clickable').- | MouseUp n (Maybe Button) Location+ | MouseUp !n !(Maybe Button) !Location -- ^ A mouse-up event on the specified region was -- received. The 'n' value is the resource name of -- the clicked widget (see 'clickable'). deriving (Show, Eq, Ord) -data EventRO n = EventRO { eventViewportMap :: M.Map n Viewport- , latestExtents :: [Extent n]- , oldState :: RenderState n+data EventRO n = EventRO { eventViewportMap :: !(M.Map n Viewport)+ , latestExtents :: ![LayerExtents n]+ , oldState :: !(RenderState n) } -- | Clickable elements of a scroll bar.@@ -396,22 +468,23 @@ -- to render, which bordering style should be used, and the attribute map -- available for rendering. data Context n =- Context { ctxAttrName :: AttrName- , availWidth :: Int- , availHeight :: Int- , windowWidth :: Int- , windowHeight :: Int- , ctxBorderStyle :: BorderStyle- , ctxAttrMap :: AttrMap- , ctxDynBorders :: Bool- , ctxVScrollBarOrientation :: Maybe VScrollBarOrientation- , ctxVScrollBarRenderer :: Maybe (ScrollbarRenderer n)- , ctxHScrollBarOrientation :: Maybe HScrollBarOrientation- , ctxHScrollBarRenderer :: Maybe (ScrollbarRenderer n)- , ctxVScrollBarShowHandles :: Bool- , ctxHScrollBarShowHandles :: Bool- , ctxVScrollBarClickableConstr :: Maybe (ClickableScrollbarElement -> n -> n)- , ctxHScrollBarClickableConstr :: Maybe (ClickableScrollbarElement -> n -> n)+ Context { ctxAttrName :: !AttrName+ , availWidth :: !Int+ , availHeight :: !Int+ , windowWidth :: !Int+ , windowHeight :: !Int+ , ctxBorderStyle :: !BorderStyle+ , ctxAttrMap :: !AttrMap+ , ctxOrigAttrMap :: !AttrMap+ , ctxDynBorders :: !Bool+ , ctxVScrollBarOrientation :: !(Maybe VScrollBarOrientation)+ , ctxVScrollBarRenderer :: !(Maybe (VScrollbarRenderer n))+ , ctxHScrollBarOrientation :: !(Maybe HScrollBarOrientation)+ , ctxHScrollBarRenderer :: !(Maybe (HScrollbarRenderer n))+ , ctxVScrollBarShowHandles :: !Bool+ , ctxHScrollBarShowHandles :: !Bool+ , ctxVScrollBarClickableConstr :: !(Maybe (ClickableScrollbarElement -> n -> n))+ , ctxHScrollBarClickableConstr :: !(Maybe (ClickableScrollbarElement -> n -> n)) } suffixLenses ''RenderState@@ -423,7 +496,63 @@ suffixLenses ''BorderSegment makeLenses ''Viewport +instance TerminalLocation (CursorLocation n) where+ locationColumnL = cursorLocationL._1+ locationColumn = locationColumn . cursorLocation+ locationRowL = cursorLocationL._2+ locationRow = locationRow . cursorLocation++-- | Add a 'Location' offset to the specified 'CursorLocation'.+clOffset :: CursorLocation n -> Location -> CursorLocation n+clOffset cl off = cl & cursorLocationL %~ (<> off)+ lookupReportedExtent :: (Ord n) => n -> RenderM n (Maybe (Extent n)) lookupReportedExtent n = do m <- lift $ use reportedExtentsL return $ M.lookup n m++-- | Add an offset to all cursor locations, visibility requests, and+-- extents in the specified rendering result. This function is critical+-- for maintaining correctness in the rendering results as they are+-- processed successively by box layouts and other wrapping combinators,+-- since calls to this function result in converting from widget-local+-- coordinates to (ultimately) terminal-global ones so they can be+-- used by other combinators. You should call this any time you render+-- something and offset it from its original origin.+--+-- Note that this does not modify the translation offset of this result,+-- but it does offset the translations of this result's extra layers+-- so that they maintain their relative position with respect to this+-- result.+addResultOffset :: Location -> Result n -> Result n+addResultOffset (Location (0, 0)) = id+addResultOffset off =+ addCursorOffset off .+ addVisibilityOffset off .+ addExtentOffset off .+ addDynBorderOffset off .+ addExtraLayersOffset off++addVisibilityOffset :: Location -> Result n -> Result n+addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>)++addExtentOffset :: Location -> Result n -> Result n+addExtentOffset off r = r & extentsL.each %~ (\(Extent n l sz) -> Extent n (off <> l) sz)++addDynBorderOffset :: Location -> Result n -> Result n+addDynBorderOffset off r = r & bordersL %~ BM.translate off++addCursorOffset :: Location -> Result n -> Result n+addCursorOffset off r =+ let onlyVisible = filter isVisible+ isVisible l = l^.locationColumnL >= 0 && l^.locationRowL >= 0+ in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs)++-- | Add an offset to the translation offset for this result.+addTranslationOffset :: Location -> Result n -> Result n+addTranslationOffset (Location (0, 0)) r = r+addTranslationOffset off r =+ r & translationOffsetL %~ (off <>)++addExtraLayersOffset :: Location -> Result n -> Result n+addExtraLayersOffset off r = r & extraLayersL %~ (fmap (addTranslationOffset off))
src/Brick/Util.hs view
@@ -4,17 +4,18 @@ , on , fg , bg+ , style , clOffset ) where -import Lens.Micro ((&), (%~)) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif import Graphics.Vty -import Brick.Types.Internal (Location(..), CursorLocation(..), cursorLocationL)+-- Re-export clOffset for backwards compatibility.+import Brick.Types.Internal (clOffset) -- | Given a minimum value and a maximum value, clamp a value to that -- range (values less than the minimum map to the minimum and values@@ -52,10 +53,11 @@ fg = (defAttr `withForeColor`) -- | Create an attribute from the specified background color (the--- background color is the "default").+-- foreground color is the "default"). bg :: Color -> Attr bg = (defAttr `withBackColor`) --- | Add a 'Location' offset to the specified 'CursorLocation'.-clOffset :: CursorLocation n -> Location -> CursorLocation n-clOffset cl off = cl & cursorLocationL %~ (<> off)+-- | Create an attribute from the specified style (the colors are the+-- "default").+style :: Style -> Attr+style = (defAttr `withStyle`)
src/Brick/Widgets/Border.hs view
@@ -20,12 +20,17 @@ -- * Attribute names , borderAttr+ , hBorderAttr+ , vBorderAttr -- * Utility , joinableBorder ) where +#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif import Lens.Micro ((^.), (&), (.~), to) import Graphics.Vty (imageHeight, imageWidth) @@ -41,6 +46,14 @@ borderAttr :: AttrName borderAttr = attrName "border" +-- | The horizontal border attribute name. Inherits from 'borderAttr'.+hBorderAttr :: AttrName+hBorderAttr = borderAttr <> attrName "horizontal"++-- | The vertical border attribute name. Inherits from 'borderAttr'.+vBorderAttr :: AttrName+vBorderAttr = borderAttr <> attrName "vertical"+ -- | Draw the specified border element using the active border style -- using 'borderAttr'. --@@ -95,7 +108,8 @@ $ vLimit (middleResult^.imageL.to imageHeight + 2) $ total --- | A horizontal border. Fills all horizontal space.+-- | A horizontal border. Fills all horizontal space. Draws using+-- 'hBorderAttr'. hBorder :: Widget n hBorder = withAttr borderAttr $ Widget Greedy Fixed $ do@@ -105,7 +119,8 @@ db <- dynBorderFromDirections (Edges False False True True) let dynBorders = BM.insertH mempty (Run w db) $ BM.emptyCoordinates (Edges 0 0 0 (w-1))- setDynBorders dynBorders $ render $ vLimit 1 $ fill (bsHorizontal bs)+ setDynBorders dynBorders $ render $ withAttr hBorderAttr+ $ vLimit 1 $ fill (bsHorizontal bs) -- | A horizontal border with a label placed in the center of the -- border. Fills all horizontal space.@@ -117,7 +132,8 @@ res <- render $ vLimit 1 label render $ hBox [hBorder, Widget Fixed Fixed (return res), hBorder] --- | A vertical border. Fills all vertical space.+-- | A vertical border. Fills all vertical space. Draws using+-- 'vBorderAttr'. vBorder :: Widget n vBorder = withAttr borderAttr $ Widget Fixed Greedy $ do@@ -127,7 +143,8 @@ db <- dynBorderFromDirections (Edges True True False False) let dynBorders = BM.insertV mempty (Run h db) $ BM.emptyCoordinates (Edges 0 (h-1) 0 0)- setDynBorders dynBorders $ render $ hLimit 1 $ fill (bsVertical bs)+ setDynBorders dynBorders $ render $ withAttr vBorderAttr+ $ hLimit 1 $ fill (bsVertical bs) -- | Initialize a 'DynBorder'. It will be 'bsDraw'n and 'bsOffer'ing -- in the given directions to begin with, and accept join offers from
src/Brick/Widgets/Center.hs view
@@ -19,8 +19,7 @@ import Lens.Micro ((^.), (&), (.~), to) import Data.Maybe (fromMaybe)-import Graphics.Vty (imageWidth, imageHeight, horizCat, charFill, vertCat,- translateX, translateY)+import Graphics.Vty (imageWidth, imageHeight, horizCat, charFill, vertCat) import Brick.Types import Brick.Widgets.Core@@ -30,11 +29,11 @@ hCenter :: Widget n -> Widget n hCenter = hCenterWith Nothing --- | Center the specified widget horizontally using a Vty image--- translation. Consumes all available horizontal space. Unlike hCenter,--- this does not fill the surrounding space so it is suitable for use--- as a layer. Layers underneath this widget will be visible in regions--- surrounding the centered widget.+-- | Center the specified widget horizontally using a layer translation.+-- Consumes all available horizontal space. Unlike hCenter, this does+-- not fill the surrounding space so it is suitable for use as a layer.+-- Layers underneath this widget will be visible in regions surrounding+-- the centered widget. hCenterLayer :: Widget n -> Widget n hCenterLayer p = Widget Greedy (vSize p) $ do@@ -42,12 +41,8 @@ c <- getContext let rWidth = result^.imageL.to imageWidth leftPaddingAmount = max 0 $ (c^.availWidthL - rWidth) `div` 2- paddedImage = translateX leftPaddingAmount $ result^.imageL off = Location (leftPaddingAmount, 0)- if leftPaddingAmount == 0 then- return result else- return $ addResultOffset off- $ result & imageL .~ paddedImage+ render $ translateLayer off $ Widget Fixed Fixed $ return result -- | Center the specified widget horizontally. Consumes all available -- horizontal space. Uses the specified character to fill in the space@@ -60,7 +55,7 @@ c <- getContext let rWidth = result^.imageL.to imageWidth rHeight = result^.imageL.to imageHeight- remainder = max 0 $ c^.availWidthL - (leftPaddingAmount * 2)+ remainder = max 0 $ c^.availWidthL - (rWidth + (leftPaddingAmount * 2)) leftPaddingAmount = max 0 $ (c^.availWidthL - rWidth) `div` 2 rightPaddingAmount = max 0 $ leftPaddingAmount + remainder leftPadding = charFill (c^.attrL) ch leftPaddingAmount rHeight@@ -79,11 +74,11 @@ vCenter :: Widget n -> Widget n vCenter = vCenterWith Nothing --- | Center the specified widget vertically using a Vty image--- translation. Consumes all available vertical space. Unlike vCenter,--- this does not fill the surrounding space so it is suitable for use--- as a layer. Layers underneath this widget will be visible in regions--- surrounding the centered widget.+-- | Center the specified widget vertically using a layer translation.+-- Consumes all available vertical space. Unlike vCenter, this does not+-- fill the surrounding space so it is suitable for use as a layer.+-- Layers underneath this widget will be visible in regions surrounding+-- the centered widget. vCenterLayer :: Widget n -> Widget n vCenterLayer p = Widget (hSize p) Greedy $ do@@ -91,12 +86,8 @@ c <- getContext let rHeight = result^.imageL.to imageHeight topPaddingAmount = max 0 $ (c^.availHeightL - rHeight) `div` 2- paddedImage = translateY topPaddingAmount $ result^.imageL off = Location (0, topPaddingAmount)- if topPaddingAmount == 0 then- return result else- return $ addResultOffset off- $ result & imageL .~ paddedImage+ render $ translateLayer off $ Widget Fixed Fixed $ return result -- | Center a widget vertically. Consumes all vertical space. Uses the -- specified character to fill in the space above and below the centered@@ -135,7 +126,7 @@ centerWith :: Maybe Char -> Widget n -> Widget n centerWith c = vCenterWith c . hCenterWith c --- | Center a widget both vertically and horizontally using a Vty image+-- | Center a widget both vertically and horizontally using a layer -- translation. Consumes all available vertical and horizontal space. -- Unlike center, this does not fill in the surrounding space with a -- character so it is usable as a layer. Any widget underneath this one@@ -153,10 +144,10 @@ c <- getContext let centerW = c^.availWidthL `div` 2 centerH = c^.availHeightL `div` 2- off = Location ( centerW - l^.locationColumnL- , centerH - l^.locationRowL- )- result <- render $ translateBy off p+ hOff = centerW - l^.locationColumnL+ vOff = centerH - l^.locationRowL++ result <- render $ padLeft (Pad hOff) $ padTop (Pad vOff) p -- Pad the result so it consumes available space let rightPaddingAmt = max 0 $ c^.availWidthL - imageWidth (result^.imageL)
src/Brick/Widgets/Core.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -- | This module provides the core widget combinators and rendering -- routines. Everything this library does is in terms of these basic -- primitives.@@ -12,6 +13,7 @@ TextWidth(..) , emptyWidget , raw+ , char , txt , txtWrap , txtWrapWith@@ -49,6 +51,7 @@ , modifyDefAttr , withAttr , forceAttr+ , forceAttrAllowStyle , overrideAttr , updateAttrMap @@ -65,9 +68,11 @@ -- * Naming , Named(..) - -- * Translation and positioning- , translateBy- , relativeTo+ -- * Layer translation and positioning+ , translateLayer+ , layerRelativeTo+ , above+ , clampLayerToScreen -- * Cropping , cropLeftBy@@ -83,12 +88,14 @@ , reportExtent , clickable + -- * Caching widget renderings+ , cached+ -- * Scrollable viewports , viewport , visible , visibleRegion , unsafeLookupViewport- , cached -- ** Viewport scroll bars , withVScrollBars@@ -99,7 +106,8 @@ , withHScrollBarHandles , withVScrollBarRenderer , withHScrollBarRenderer- , ScrollbarRenderer(..)+ , VScrollbarRenderer(..)+ , HScrollbarRenderer(..) , verticalScrollbarRenderer , horizontalScrollbarRenderer , scrollbarAttr@@ -120,10 +128,12 @@ import Data.Monoid ((<>)) #endif -import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, each, to, Lens')+import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, to, Lens') import Lens.Micro.Mtl (use, (%=))+import Control.Monad import Control.Monad.State.Strict import Control.Monad.Reader+import qualified Data.Sequence as Seq import qualified Data.Foldable as F import Data.Traversable (for) import qualified Data.Text as T@@ -132,7 +142,7 @@ import qualified Data.IMap as I import qualified Data.Function as DF import Data.List (sortBy, partition)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, fromJust) import qualified Graphics.Vty as V import Control.DeepSeq @@ -141,7 +151,7 @@ import Brick.Types import Brick.Types.Internal import Brick.Widgets.Border.Style-import Brick.Util (clOffset, clamp)+import Brick.Util (clamp) import Brick.AttrMap import Brick.Widgets.Internal import qualified Brick.BorderMap as BM@@ -154,7 +164,7 @@ textWidth :: a -> Int instance TextWidth T.Text where- textWidth = V.wcswidth . T.unpack+ textWidth = V.wctwidth instance (F.Foldable f) => TextWidth (f Char) where textWidth = V.wcswidth . F.toList@@ -170,15 +180,16 @@ withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (ctxBorderStyleL .~ bs) (render p) --- | When rendering the specified widget, create borders that respond--- dynamically to their neighbors to form seamless connections.+-- | When rendering the specified widget, draw any borders dynamically+-- so that they connect with each other when they're adjacent. joinBorders :: Widget n -> Widget n joinBorders p = Widget (hSize p) (vSize p) $ withReaderT (ctxDynBordersL .~ True) (render p) --- | When rendering the specified widget, use static borders. This--- may be marginally faster, but will introduce a small gap between--- neighboring orthogonal borders.+-- | When rendering the specified widget, use static borders that do not+-- connect to each other dynamically. This may be marginally faster, but+-- will leave a small visual gap between adjacent borders that would+-- otherwise touch. -- -- This is the default for backwards compatibility. separateBorders :: Widget n -> Widget n@@ -186,10 +197,11 @@ withReaderT (ctxDynBordersL .~ False) (render p) -- | After the specified widget has been rendered, freeze its borders. A--- frozen border will not be affected by neighbors, nor will it affect--- neighbors. Compared to 'separateBorders', 'freezeBorders' will not--- affect whether borders connect internally to a widget (whereas--- 'separateBorders' prevents them from connecting).+-- frozen border will not be affected by adjacent borders, nor will it+-- affect other adjacent borders in the enclosing widget. Compared to+-- 'separateBorders', 'freezeBorders' will not affect whether borders+-- connect internally to a widget (whereas 'separateBorders' prevents+-- them from connecting). -- -- Frozen borders cannot be thawed. freezeBorders :: Widget n -> Widget n@@ -199,30 +211,6 @@ emptyWidget :: Widget n emptyWidget = raw V.emptyImage --- | Add an offset to all cursor locations, visibility requests, and--- extents in the specified rendering result. This function is critical--- for maintaining correctness in the rendering results as they are--- processed successively by box layouts and other wrapping combinators,--- since calls to this function result in converting from widget-local--- coordinates to (ultimately) terminal-global ones so they can be--- used by other combinators. You should call this any time you render--- something and then translate it or otherwise offset it from its--- original origin.-addResultOffset :: Location -> Result n -> Result n-addResultOffset off = addCursorOffset off .- addVisibilityOffset off .- addExtentOffset off .- addDynBorderOffset off--addVisibilityOffset :: Location -> Result n -> Result n-addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>)--addExtentOffset :: Location -> Result n -> Result n-addExtentOffset off r = r & extentsL.each %~ (\(Extent n l sz) -> Extent n (off <> l) sz)--addDynBorderOffset :: Location -> Result n -> Result n-addDynBorderOffset off r = r & bordersL %~ BM.translate off- -- | Render the specified widget and record its rendering extent using -- the specified name (see also 'lookupExtent'). --@@ -256,29 +244,12 @@ clickable :: (Ord n) => n -> Widget n -> Widget n clickable n p = Widget (hSize p) (vSize p) $ do- clickableNamesL %= (n:)+ clickableNamesL %= S.insert n render $ reportExtent n p -addCursorOffset :: Location -> Result n -> Result n-addCursorOffset off r =- let onlyVisible = filter isVisible- isVisible l = l^.locationColumnL >= 0 && l^.locationRowL >= 0- in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs)- unrestricted :: Int unrestricted = 100000 --- | Take a substring capable of fitting into the number of specified--- columns. This function takes character column widths into--- consideration.-takeColumns :: Int -> String -> String-takeColumns _ "" = ""-takeColumns numCols (c:cs) =- let w = V.safeWcwidth c- in if w > numCols- then []- else c : takeColumns (numCols - w) cs- -- | Make a widget from a string, but wrap the words in the input's -- lines at the available width using the default wrapping settings. The -- input string should not contain escape sequences or carriage returns.@@ -296,9 +267,6 @@ strWrapWith :: WrapSettings -> String -> Widget n strWrapWith settings t = txtWrapWith settings $ T.pack t -safeTextWidth :: T.Text -> Int-safeTextWidth = V.safeWcswidth . T.unpack- -- | Make a widget from text, but wrap the words in the input's lines at -- the available width using the default wrapping settings. The input -- text should not contain escape sequences or carriage returns.@@ -322,15 +290,23 @@ case force theLines of [] -> return emptyResult multiple ->- let maxLength = maximum $ safeTextWidth <$> multiple+ let maxLength = maximum $ fst <$> linesWithLength+ linesWithLength = (\l -> (textWidth l, l)) <$> multiple padding = V.charFill (c^.attrL) ' ' (c^.availWidthL - maxLength) (length lineImgs)- lineImgs = lineImg <$> multiple- lineImg lStr = V.text' (c^.attrL)- (lStr <> T.replicate (maxLength - safeTextWidth lStr) " ")+ lineImgs = lineImg <$> linesWithLength+ lineImg (len, lStr) = V.text' (c^.attrL)+ (lStr <> T.replicate (maxLength - len) " ") in return $ emptyResult & imageL .~ (V.horizCat [V.vertCat lineImgs, padding]) --- | Build a widget from a 'String'. Breaks newlines up and space-pads--- short lines out to the length of the longest line.+-- | Build a widget from a single character.+char :: Char -> Widget n+char ch =+ Widget Fixed Fixed $ do+ c <- getContext+ return $ emptyResult & imageL .~ (V.char (c^.attrL) ch)++-- | Build a widget from a 'String'. Behaves the same as 'txt' when the+-- input contains multiple lines. -- -- The input string must not contain tab characters. If it does, -- interface corruption will result since the terminal will likely@@ -338,25 +314,10 @@ -- replace tabs with the appropriate number of spaces as desired. The -- input string should not contain escape sequences or carriage returns. str :: String -> Widget n-str s =- Widget Fixed Fixed $ do- c <- getContext- let theLines = fixEmpty <$> (dropUnused . lines) s- fixEmpty :: String -> String- fixEmpty [] = " "- fixEmpty l = l- dropUnused l = takeColumns (availWidth c) <$> take (availHeight c) l- case force theLines of- [] -> return emptyResult- [one] -> return $ emptyResult & imageL .~ (V.string (c^.attrL) one)- multiple ->- let maxLength = maximum $ V.safeWcswidth <$> multiple- lineImgs = lineImg <$> multiple- lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - V.safeWcswidth lStr) ' ')- in return $ emptyResult & imageL .~ (V.vertCat lineImgs)+str = txt . T.pack --- | Build a widget from a 'T.Text' value. Behaves the same as 'str'--- when the input contains multiple lines.+-- | Build a widget from a 'T.Text' value. Breaks newlines up and+-- space-pads short lines out to the length of the longest line. -- -- The input string must not contain tab characters. If it does, -- interface corruption will result since the terminal will likely@@ -364,8 +325,46 @@ -- replace tabs with the appropriate number of spaces as desired. The -- input text should not contain escape sequences or carriage returns. txt :: T.Text -> Widget n-txt = str . T.unpack+txt s =+ -- Although vty Image uses lazy Text internally, using lazy text at this+ -- level may not be an improvement. Indeed it can be much worse, due+ -- the overhead of lazy Text being significant compared to the typically+ -- short string content used to compose UIs.+ Widget Fixed Fixed $ do+ c <- getContext+ let theLines = fixEmpty <$> (dropUnused . T.lines) s+ fixEmpty l = if T.null l then T.singleton ' ' else l+ dropUnused l = takeColumnsT (availWidth c) <$> take (availHeight c) l+ pure $ case theLines of+ [] -> emptyResult+ [one] -> emptyResult & imageL .~ (V.text' (c^.attrL) one)+ multiple ->+ let maxLength = maximum $ fst <$> linesWithLength+ linesWithLength = (\l -> (V.safeWctwidth l, l)) <$> multiple+ lineImgs = lineImg <$> linesWithLength+ lineImg (len, lStr) = V.text' (c^.attrL)+ (lStr <> T.replicate (maxLength - len) (T.singleton ' '))+ in emptyResult & imageL .~ (V.vertCat lineImgs) +-- | Take up to the given width, having regard to character width.+takeColumnsT :: Int -> T.Text -> T.Text+takeColumnsT w s = T.take (fst $ T.foldl' f (0,0) s) s+ where+ -- The accumulator value is (index in Text value, width of Text so far)+ f (i,z) c+ -- Width was previously exceeded; continue with same values.+ | z < 0 = (i, z)+ -- Width exceeded. Signal this with z = -1. Index will no longer be+ -- incremented.+ --+ -- Why not short circuit (e.g. using foldlM construction)?+ -- Because in the typical case, the Either allocation costs exceed+ -- any benefits. The pathological case, string length >> width, is+ -- probably rare.+ | z + V.safeWcwidth c > w = (i, -1)+ -- Width not yet exceeded. Increment index and add character width.+ | otherwise = (i + 1, z + V.safeWcwidth c)+ -- | Hyperlink the given widget to the specified URL. Not all terminal -- emulators support this. In those that don't, this should have no -- discernible effect.@@ -476,6 +475,19 @@ -- in the specified order (uppermost first). Defers growth policies to -- the growth policies of the contained widgets (if any are greedy, so -- is the box).+--+-- Allocates space to 'Fixed' elements first and 'Greedy' elements+-- second. For example, if a 'vBox' contains three elements @A@, @B@,+-- and @C@, and if @A@ and @B@ are 'Fixed', then 'vBox' first renders+-- @A@ and @B@. Suppose those two take up 10 rows total, and the 'vBox'+-- was given 50 rows. This means 'vBox' then allocates the remaining+-- 40 rows to @C@. If, on the other hand, @A@ and @B@ take up 50 rows+-- together, @C@ will not be rendered at all.+--+-- If all elements are 'Greedy', 'vBox' allocates the available height+-- evenly among the elements. So, for example, if a 'vBox' is rendered+-- in 90 rows and has three 'Greedy' elements, each element will be+-- allocated 30 rows. {-# NOINLINE vBox #-} vBox :: [Widget n] -> Widget n vBox [] = emptyWidget@@ -486,6 +498,19 @@ -- in the specified order (leftmost first). Defers growth policies to -- the growth policies of the contained widgets (if any are greedy, so -- is the box).+--+-- Allocates space to 'Fixed' elements first and 'Greedy' elements+-- second. For example, if an 'hBox' contains three elements @A@, @B@,+-- and @C@, and if @A@ and @B@ are 'Fixed', then 'hBox' first renders+-- @A@ and @B@. Suppose those two take up 10 columns total, and the+-- 'hBox' was given 50 columns. This means 'hBox' then allocates the+-- remaining 40 columns to @C@. If, on the other hand, @A@ and @B@ take+-- up 50 columns together, @C@ will not be rendered at all.+--+-- If all elements are 'Greedy', 'hBox' allocates the available width+-- evenly among the elements. So, for example, if an 'hBox' is rendered+-- in 90 columns and has three 'Greedy' elements, each element will be+-- allocated 30 columns. {-# NOINLINE hBox #-} hBox :: [Widget n] -> Widget n hBox [] = emptyWidget@@ -508,7 +533,6 @@ , imagePrimary :: V.Image -> Int , imageSecondary :: V.Image -> Int , limitPrimary :: Int -> Widget n -> Widget n- , limitSecondary :: Int -> Widget n -> Widget n , primaryWidgetSize :: Widget n -> Size , concatenatePrimary :: [V.Image] -> V.Image , concatenateSecondary :: [V.Image] -> V.Image@@ -534,7 +558,6 @@ , imagePrimary = V.imageHeight , imageSecondary = V.imageWidth , limitPrimary = vLimit- , limitSecondary = hLimit , primaryWidgetSize = vSize , concatenatePrimary = V.vertCat , concatenateSecondary = V.horizCat@@ -562,7 +585,6 @@ , imagePrimary = V.imageWidth , imageSecondary = V.imageHeight , limitPrimary = hLimit- , limitSecondary = vLimit , primaryWidgetSize = hSize , concatenatePrimary = V.horizCat , concatenateSecondary = V.vertCat@@ -639,18 +661,13 @@ (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed) pairsIndexed - let availPrimary = c^.(contextPrimary br)- availSecondary = c^.(contextSecondary br)- renderHi prim = do remainingPrimary <- get- result <- lift $ render $ limitPrimary br remainingPrimary- $ limitSecondary br availSecondary- $ cropToContext prim+ result <- lift $ render $ limitPrimary br remainingPrimary prim result <$ (put $! remainingPrimary - (result^.imageL.(to $ imagePrimary br))) (renderedHis, remainingPrimary) <-- runStateT (traverse (traverse renderHi) his) availPrimary+ runStateT (traverse (traverse renderHi) his) (c ^. contextPrimary br) renderedLows <- case lows of [] -> return []@@ -660,10 +677,7 @@ primaries = replicate rest (primaryPerLow + 1) <> replicate (length ls - rest) primaryPerLow - let renderLow ((i, prim), pri) =- (i,) <$> (render $ limitPrimary br pri- $ limitSecondary br availSecondary- $ cropToContext prim)+ let renderLow ((i, prim), pri) = (i,) <$> render (limitPrimary br pri prim) if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return [] @@ -691,13 +705,67 @@ (concatMap visibilityRequests allTranslatedResults) (concatMap extents allTranslatedResults) newBorders+ (Location (0, 0))+ Truncate Truncate+ (mconcat $ extraLayers <$> allTranslatedResults) -catDynBorder- :: Lens' (Edges BorderSegment) BorderSegment- -> Lens' (Edges BorderSegment) BorderSegment- -> DynBorder- -> DynBorder- -> Maybe DynBorder+-- | Given a result, crop all of its extra layers to the rendering+-- context. This is only used when rendering a result in a viewport; in+-- a viewport setting, we want to show extra layers but crop them to the+-- bounds of the viewport.+cropExtraLayersToContext :: Result n -> RenderM n (Result n)+cropExtraLayersToContext r = do+ let ls = r^.extraLayersL+ ls' <- mapM cropExtraLayerToContext ls+ return $ r & extraLayersL .~ ls'++-- | Given a layer, crop it to the rendering context. This is only used+-- when rendering a layer on top of a base layer in a viewport. In this+-- setting, we want to crop the layer so that it is confined to the+-- viewport's region. This works by assuming that the rendering context+-- represents the scrollable area of the viewport, and that the extra+-- layers on top of the base layer have been translated with respect to+-- the viewport's scrolling state, meaning that some layers may have+-- been translated to have negative left or top offsets. Negative left+-- or top offsets indicate that a layer is partially or fully obscured+-- by the viewport's visible area, and right or bottom portions of+-- layers that exceed the bounds of the scrollable area will exceed the+-- rendering context's size so normal 'cropResultToContext' behavior+-- will crop them.+--+-- In all cases, the extra layer will be cropped on all sides as+-- necessary to limit its visible portion to whatever is permitted by+-- its base layer's scroll position in the viewport, since that has been+-- used to set up the rendering context and layer translation.+cropExtraLayerToContext :: Result n -> RenderM n (Result n)+cropExtraLayerToContext r = do+ ctx <- getContext++ let hOff = r^.translationOffsetL.locationColumnL+ vOff = r^.translationOffsetL.locationRowL+ leftCropAmt = abs $ min 0 hOff+ topCropAmt = abs $ min 0 vOff+ iWidth = V.imageWidth $ r^.imageL+ iHeight = V.imageHeight $ r^.imageL+ rightCropAmt = max (hOff + iWidth - ctx^.availWidthL) 0+ bottomCropAmt = max (vOff + iHeight - ctx^.availHeightL) 0+ maybeCropLeft = if leftCropAmt > 0 then cropLeftBy leftCropAmt else id+ maybeCropTop = if topCropAmt > 0 then cropTopBy topCropAmt else id++ r' <- addTranslationOffset (Location (leftCropAmt, topCropAmt)) <$>+ (render $ cropRightBy rightCropAmt $+ cropBottomBy bottomCropAmt $+ maybeCropLeft $+ maybeCropTop $+ Widget Fixed Fixed $ return r)++ cropExtraLayersToContext r'++catDynBorder :: Lens' (Edges BorderSegment) BorderSegment+ -> Lens' (Edges BorderSegment) BorderSegment+ -> DynBorder+ -> DynBorder+ -> Maybe DynBorder catDynBorder towardsA towardsB a b -- Currently, we check if the 'BorderStyle's are exactly the same. In the -- future, it might be nice to relax this restriction. For example, if a@@ -715,12 +783,11 @@ = Just (a & dbSegmentsL.towardsB.bsDrawL .~ True) | otherwise = Nothing -catDynBorders- :: Lens' (Edges BorderSegment) BorderSegment- -> Lens' (Edges BorderSegment) BorderSegment- -> I.IMap DynBorder- -> I.IMap DynBorder- -> I.IMap DynBorder+catDynBorders :: Lens' (Edges BorderSegment) BorderSegment+ -> Lens' (Edges BorderSegment) BorderSegment+ -> I.IMap DynBorder+ -> I.IMap DynBorder+ -> I.IMap DynBorder catDynBorders towardsA towardsB am bm = I.mapMaybe id $ I.intersectionWith (catDynBorder towardsA towardsB) am bm @@ -730,9 +797,8 @@ -- images to keep the image in sync with the border information. -- -- The input borders are assumed to be disjoint. This property is not checked.-catBorders- :: (border ~ BM.BorderMap DynBorder, rewrite ~ I.IMap V.Image)- => BoxRenderer n -> border -> border -> ((rewrite, rewrite), border)+catBorders :: (border ~ BM.BorderMap DynBorder, rewrite ~ I.IMap V.Image)+ => BoxRenderer n -> border -> border -> ((rewrite, rewrite), border) catBorders br r l = if lCoord + 1 == rCoord then ((lRe, rRe), lr') else ((I.empty, I.empty), lr)@@ -761,20 +827,20 @@ -- overlap and are strictly increasing in the primary direction), produce: a -- list of rewrites for the lo and hi directions of each border, respectively, -- and the borders describing the fully concatenated object.-catAllBorders ::- BoxRenderer n ->- [BM.BorderMap DynBorder] ->- ([(I.IMap V.Image, I.IMap V.Image)], BM.BorderMap DynBorder)+catAllBorders :: BoxRenderer n+ -> [BM.BorderMap DynBorder]+ -> ([(I.IMap V.Image, I.IMap V.Image)], BM.BorderMap DynBorder) catAllBorders _ [] = ([], BM.empty) catAllBorders br (bm:bms) = (zip ([I.empty]++los) (his++[I.empty]), bm') where (rewrites, bm') = runState (traverse (state . catBorders br) bms) bm (his, los) = unzip rewrites -rewriteEdge ::- (Int -> V.Image -> V.Image) ->- (Int -> V.Image -> V.Image) ->- ([V.Image] -> V.Image) ->- I.IMap V.Image -> V.Image -> V.Image+rewriteEdge :: (Int -> V.Image -> V.Image)+ -> (Int -> V.Image -> V.Image)+ -> ([V.Image] -> V.Image)+ -> I.IMap V.Image+ -> V.Image+ -> V.Image rewriteEdge splitLo splitHi combine = (combine .) . go . offsets 0 . I.unsafeToAscList where -- convert absolute positions into relative ones@@ -811,9 +877,11 @@ -- growth of otherwise-greedy widgets. This is non-greedy horizontally -- and defers to the limited widget vertically. hLimit :: Int -> Widget n -> Widget n-hLimit w p =- Widget Fixed (vSize p) $- withReaderT (availWidthL %~ (min w)) $ render $ cropToContext p+hLimit w p+ | w <= 0 = emptyWidget+ | otherwise =+ Widget Fixed (vSize p) $+ withReaderT (availWidthL %~ (min w)) $ render $ cropToContext p -- | Limit the space available to the specified widget to the specified -- percentage of available width, as a value between 0 and 100@@ -822,22 +890,26 @@ -- growth of otherwise-greedy widgets. This is non-greedy horizontally -- and defers to the limited widget vertically. hLimitPercent :: Int -> Widget n -> Widget n-hLimitPercent w' p =- Widget Fixed (vSize p) $ do- let w = clamp 0 100 w'- ctx <- getContext- let usableWidth = ctx^.availWidthL- widgetWidth = round (toRational usableWidth * (toRational w / 100))- withReaderT (availWidthL %~ (min widgetWidth)) $ render $ cropToContext p+hLimitPercent w' p+ | w' <= 0 = emptyWidget+ | otherwise =+ Widget Fixed (vSize p) $ do+ let w = clamp 0 100 w'+ ctx <- getContext+ let usableWidth = ctx^.availWidthL+ widgetWidth = round (toRational usableWidth * (toRational w / 100))+ withReaderT (availWidthL %~ (min widgetWidth)) $ render $ cropToContext p -- | Limit the space available to the specified widget to the specified -- number of rows. This is important for constraining the vertical -- growth of otherwise-greedy widgets. This is non-greedy vertically and -- defers to the limited widget horizontally. vLimit :: Int -> Widget n -> Widget n-vLimit h p =- Widget (hSize p) Fixed $- withReaderT (availHeightL %~ (min h)) $ render $ cropToContext p+vLimit h p+ | h <= 0 = emptyWidget+ | otherwise =+ Widget (hSize p) Fixed $+ withReaderT (availHeightL %~ (min h)) $ render $ cropToContext p -- | Limit the space available to the specified widget to the specified -- percentage of available height, as a value between 0 and 100@@ -846,22 +918,26 @@ -- growth of otherwise-greedy widgets. This is non-greedy vertically and -- defers to the limited widget horizontally. vLimitPercent :: Int -> Widget n -> Widget n-vLimitPercent h' p =- Widget (hSize p) Fixed $ do- let h = clamp 0 100 h'- ctx <- getContext- let usableHeight = ctx^.availHeightL- widgetHeight = round (toRational usableHeight * (toRational h / 100))- withReaderT (availHeightL %~ (min widgetHeight)) $ render $ cropToContext p+vLimitPercent h' p+ | h' <= 0 = emptyWidget+ | otherwise =+ Widget (hSize p) Fixed $ do+ let h = clamp 0 100 h'+ ctx <- getContext+ let usableHeight = ctx^.availHeightL+ widgetHeight = round (toRational usableHeight * (toRational h / 100))+ withReaderT (availHeightL %~ (min widgetHeight)) $ render $ cropToContext p -- | Set the rendering context height and width for this widget. This -- is useful for relaxing the rendering size constraints on e.g. layer -- widgets where cropping to the screen size is undesirable. setAvailableSize :: (Int, Int) -> Widget n -> Widget n-setAvailableSize (w, h) p =- Widget Fixed Fixed $- withReaderT (\c -> c & availHeightL .~ h & availWidthL .~ w) $- render $ cropToContext p+setAvailableSize (w, h) p+ | w <= 0 || h <= 0 = emptyWidget+ | otherwise =+ Widget Fixed Fixed $+ withReaderT (\c -> c & availHeightL .~ h & availWidthL .~ w) $+ 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@@ -886,7 +962,7 @@ -- , withAttr "highlight" (str b) -- ] ----- render1 = renderA ("Brick", "fun")+-- render1 = renderA (\"Brick\", "fun") -- render2 = withAttr "warning" render1 -- @ --@@ -930,7 +1006,7 @@ -- , str " is " -- , withAttr "highlight" (str b) ] ----- render1 = renderA ("Brick", "fun")+-- render1 = renderA (\"Brick\", "fun") -- render2 = withDefAttr "warning" render1 -- @ --@@ -994,6 +1070,17 @@ c <- getContext withReaderT (ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p) +-- | Like 'forceAttr', except that the style of attribute lookups in the+-- attribute map is preserved and merged with the forced attribute. This+-- allows for situations where 'forceAttr' would otherwise ignore style+-- information that is important to preserve.+forceAttrAllowStyle :: AttrName -> Widget n -> Widget n+forceAttrAllowStyle an p =+ Widget (hSize p) (vSize p) $ do+ c <- getContext+ let m = c^.ctxAttrMapL+ withReaderT (ctxAttrMapL .~ (forceAttrMapAllowStyle (attrMapLookup an m) m)) (render p)+ -- | Override the lookup of the attribute name 'targetName' to return -- the attribute value associated with 'fromName' when rendering the -- specified widget.@@ -1024,53 +1111,147 @@ raw :: V.Image -> Widget n raw img = Widget Fixed Fixed $ return $ emptyResult & imageL .~ img --- | Translate the specified widget by the specified offset amount.+-- | Translate the specified layer widget by the specified offset. -- Defers to the translated widget for growth policy.-translateBy :: Location -> Widget n -> Widget n-translateBy off p =- Widget (hSize p) (vSize p) $ do- result <- render p- return $ addResultOffset off- $ result & imageL %~ (V.translate (off^.locationColumnL) (off^.locationRowL))+--+-- This only applies to layer widgets, meaning that translating a+-- widget that is embedded within another widget will have no effect.+-- For example, this translation of @bar@ has no effect because @bar@ is+-- embedded in a box, and translations only apply if specified for the+-- outermost @Widget@:+--+-- > foo <+> translateLayer (Location (1, 1)) bar+--+-- @translateLayer@ does not translate immediately; instead, it records+-- a translation offset to be applied at rendering time. Subsequent+-- calls to this function on the same widget accumulate the offset.+--+-- Note that by default, layers may be cut off by screen edges when+-- translated enough so that the contents don't fit on screen; to+-- prevent this, use 'clampLayerToScreen'.+translateLayer :: Location -> Widget n -> Widget n+translateLayer (Location (0, 0)) w = w+translateLayer off p =+ Widget (hSize p) (vSize p) $ addTranslationOffset off <$> render p --- | Given a widget, translate it to position it relative to the--- upper-left coordinates of a reported extent with the specified+-- | Given a layer, clamp its translation offset so that its contents+-- stay on screen even when its translation would otherwise result the+-- widget being partially or completely cut off by a screen edge.+clampLayerToScreen :: Widget n -> Widget n+clampLayerToScreen w =+ Widget (hSize w) (vSize w) $ do+ r <- render w+ return $ r & horizontalClampPolicyL .~ Reposition+ & verticalClampPolicyL .~ Reposition++-- | Given a layer widget, translate it to position it relative to+-- the upper-left coordinates of a reported extent with the specified -- positioning offset. If the specified name has no reported extent,--- this just draws the specified widget with no special positioning.------ This is only useful for positioning something in a higher layer--- relative to a reported extent in a lower layer. Any other use is--- likely to result in the specified widget being rendered as-is with--- no translation. This is because this function relies on information--- about lower layer renderings in order to work; using it with a--- resource name that wasn't rendered in a lower layer will result in--- this being equivalent to @id@.+-- this draws nothing on the basis that it only makes sense to draw what+-- was requested when the relative position is known. -- -- For example, if you have two layers @topLayer@ and @bottomLayer@, -- then a widget drawn in @bottomLayer@ with @reportExtent Foo@ can be -- used to relatively position a widget in @topLayer@ with @topLayer = -- relativeTo Foo ...@.-relativeTo :: (Ord n) => n -> Location -> Widget n -> Widget n-relativeTo n off w =+--+-- To introduce a new layer directly into the rendering process without+-- referencing a reported extent, see 'above'.+layerRelativeTo :: (Ord n) => n -> Location -> Widget n -> Widget n+layerRelativeTo n off w = Widget (hSize w) (vSize w) $ do mExt <- lookupReportedExtent n case mExt of- Nothing -> render w- Just ext -> render $ translateBy (extentUpperLeft ext <> off) w+ Nothing -> render emptyWidget+ Just ext -> render $ translateLayer (extentUpperLeft ext <> off) w +-- | @above upper lower@ introduces @upper@ as a new layer that is+-- positioned relative to the upper-left corner of @lower@. The upper+-- layer will be drawn in a rendering context with the same available+-- space as the screen, regardless of the rendering context in which+-- the lower layer is drawn. The attribute map in use for the upper+-- layer will be the same as the one for the initial rendering request,+-- meaning that any attribute changes for the lower layer will not+-- affect the upper layer's appearnce.+--+-- A layer introduced this way will be beneath any layers further up in+-- the layer stack returned by the main drawing function, so that means+-- that in this arrangement,+--+-- > draw :: s -> [Widget n]+-- > draw _ = [upper, lower]+-- >+-- > lower :: Widget n+-- > lower = middle `above` bottom+--+-- the resulting layering is @[upper, middle, bottom]@, with @middle@+-- having the same upper-left corner position as @bottom@, even+-- if @bottom@ has been translated with 'translateBy' or has been+-- positioned in a box layout.+--+-- In addition, when two layers are introduced above widgets in the same+-- layer, their ordering with respect to each other in the final layer+-- list is undefined. The only guarantee is that they will be above the+-- widget in question but underneath the nextmost layer further up in+-- the stack. For example,+--+-- > draw :: s -> [Widget n]+-- > draw _ = [upper, lower]+-- >+-- > lower :: Widget n+-- > lower = (a `above` b) <+> (c `above` d)+--+-- will result in a layer ordering with both @a@ and @c@ being beneath+-- @upper@ and above @b \<+\> d@ in the sequence, but the order of @a@ and+-- @c@ with respect to each other is undefined.+above :: Widget n -> Widget n -> Widget n+above upper lower =+ Widget (hSize lower) (vSize lower) $ do+ ctx <- getContext++ let resetConstraints = (availHeightL .~ ctx^.windowHeightL) .+ (availWidthL .~ ctx^.windowWidthL) .+ (ctxAttrNameL .~ attrName "") .+ (ctxAttrMapL .~ ctx^.ctxOrigAttrMapL)++ upperResult <- withReaderT resetConstraints $ render upper++ lowerResult <- render lower++ return $ lowerResult & extraLayersL %~ (upperResult Seq.<|)+ -- | Crop the specified widget on the left by the specified number of -- columns. Defers to the cropped widget for growth policy.+--+-- This operation crops the widget without regard for its translation+-- offset, meaning that+--+-- > cropLeftBy amt $ translateBy n w+--+-- is effectively equivalent to+--+-- > translateBy n $ cropLeftBy amt w cropLeftBy :: Int -> Widget n -> Widget n+cropLeftBy 0 p = p cropLeftBy cols p = Widget (hSize p) (vSize p) $ do result <- render p- let amt = V.imageWidth (result^.imageL) - cols- cropped img = if amt < 0 then V.emptyImage else V.cropLeft amt img- return $ addResultOffset (Location (-1 * cols, 0))- $ result & imageL %~ cropped + let img = result^.imageL+ newWidth = V.imageWidth img - cols++ withReaderT (availWidthL .~ newWidth) $+ cropResultToContext $+ if cols >= V.imageWidth img+ then emptyResult+ else addResultOffset (Location ((-1 * cols), 0)) $+ result & imageL .~ V.cropLeft newWidth img+ -- | Crop the specified widget to the specified size from the left. -- Defers to the cropped widget for growth policy.+--+-- See 'cropLeftBy' for details about how this interacts with layer+-- translations. cropLeftTo :: Int -> Widget n -> Widget n cropLeftTo cols p = Widget (hSize p) (vSize p) $ do@@ -1083,16 +1264,25 @@ -- | Crop the specified widget on the right by the specified number of -- columns. Defers to the cropped widget for growth policy.+--+-- See 'cropLeftBy' for details about how this interacts with layer+-- translations. cropRightBy :: Int -> Widget n -> Widget n+cropRightBy 0 p = p cropRightBy cols p = Widget (hSize p) (vSize p) $ do result <- render p- let amt = V.imageWidth (result^.imageL) - cols- cropped img = if amt < 0 then V.emptyImage else V.cropRight amt img- return $ result & imageL %~ cropped + let img = result^.imageL+ newWidth = V.imageWidth img - cols++ render $ hLimit newWidth $ Widget Fixed Fixed $ return result+ -- | Crop the specified widget to the specified size from the right. -- Defers to the cropped widget for growth policy.+--+-- See 'cropLeftBy' for details about how this interacts with layer+-- translations. cropRightTo :: Int -> Widget n -> Widget n cropRightTo cols p = Widget (hSize p) (vSize p) $ do@@ -1105,17 +1295,30 @@ -- | Crop the specified widget on the top by the specified number of -- rows. Defers to the cropped widget for growth policy.+--+-- See 'cropLeftBy' for details about how this interacts with layer+-- translations. cropTopBy :: Int -> Widget n -> Widget n+cropTopBy 0 p = p cropTopBy rows p = Widget (hSize p) (vSize p) $ do result <- render p- let amt = V.imageHeight (result^.imageL) - rows- cropped img = if amt < 0 then V.emptyImage else V.cropTop amt img- return $ addResultOffset (Location (0, -1 * rows))- $ result & imageL %~ cropped + let img = result^.imageL+ newHeight = V.imageHeight img - rows++ withReaderT (availHeightL .~ newHeight) $+ cropResultToContext $+ if rows >= V.imageHeight img+ then emptyResult+ else addResultOffset (Location (0, (-1 * rows))) $+ result & imageL .~ V.cropTop newHeight img+ -- | Crop the specified widget to the specified size from the top. -- Defers to the cropped widget for growth policy.+--+-- See 'cropLeftBy' for details about how this interacts with layer+-- translations. cropTopTo :: Int -> Widget n -> Widget n cropTopTo rows p = Widget (hSize p) (vSize p) $ do@@ -1128,16 +1331,25 @@ -- | Crop the specified widget on the bottom by the specified number of -- rows. Defers to the cropped widget for growth policy.+--+-- See 'cropLeftBy' for details about how this interacts with layer+-- translations. cropBottomBy :: Int -> Widget n -> Widget n+cropBottomBy 0 p = p cropBottomBy rows p = Widget (hSize p) (vSize p) $ do result <- render p- let amt = V.imageHeight (result^.imageL) - rows- cropped img = if amt < 0 then V.emptyImage else V.cropBottom amt img- return $ result & imageL %~ cropped + let img = result^.imageL+ newHeight = V.imageHeight img - rows++ render $ vLimit newHeight $ Widget Fixed Fixed $ return result+ -- | Crop the specified widget to the specified size from the bottom. -- Defers to the cropped widget for growth policy.+--+-- See 'cropLeftBy' for details about how this interacts with layer+-- translations. cropBottomTo :: Int -> Widget n -> Widget n cropBottomTo rows p = Widget (hSize p) (vSize p) $ do@@ -1191,7 +1403,7 @@ result <- cacheLookup n case result of Just (clickables, prevResult) -> do- clickableNamesL %= (clickables ++)+ clickableNamesL %= (clickables <>) return prevResult Nothing -> do wResult <- render w@@ -1201,18 +1413,18 @@ where -- Given the rendered result of a Widget, collect the list of "clickable" names -- from the extents that were in the result.- renderedClickables :: (Ord n) => Result n -> RenderM n [n]+ renderedClickables :: (Ord n) => Result n -> RenderM n (S.Set n) renderedClickables renderResult = do+ layerClickables <- S.unions <$> mapM renderedClickables (renderResult^.extraLayersL) allClickables <- use clickableNamesL- return [extentName e | e <- renderResult^.extentsL, extentName e `elem` allClickables]-+ return $ layerClickables <> S.fromList [extentName e | e <- renderResult^.extentsL, extentName e `F.elem` allClickables] -cacheLookup :: (Ord n) => n -> RenderM n (Maybe ([n], Result n))+cacheLookup :: (Ord n) => n -> RenderM n (Maybe (S.Set n, Result n)) cacheLookup n = do cache <- lift $ gets (^.renderCacheL) return $ M.lookup n cache -cacheUpdate :: Ord n => n -> ([n], Result n) -> RenderM n ()+cacheUpdate :: Ord n => n -> (S.Set n, Result n) -> RenderM n () cacheUpdate n r = lift $ modify (renderCacheL %~ M.insert n r) -- | Enable vertical scroll bars on all viewports in the specified@@ -1238,20 +1450,21 @@ -- | Render vertical viewport scroll bars in the specified widget with -- the specified renderer. This is only needed if you want to override -- the use of the default renderer, 'verticalScrollbarRenderer'.-withVScrollBarRenderer :: ScrollbarRenderer n -> Widget n -> Widget n+withVScrollBarRenderer :: VScrollbarRenderer n -> Widget n -> Widget n withVScrollBarRenderer r w = Widget (hSize w) (vSize w) $ withReaderT (ctxVScrollBarRendererL .~ Just r) (render w) -- | The default renderer for vertical viewport scroll bars. Override -- with 'withVScrollBarRenderer'.-verticalScrollbarRenderer :: ScrollbarRenderer n+verticalScrollbarRenderer :: VScrollbarRenderer n verticalScrollbarRenderer =- ScrollbarRenderer { renderScrollbar = fill '█'- , renderScrollbarTrough = fill ' '- , renderScrollbarHandleBefore = str "^"- , renderScrollbarHandleAfter = str "v"- }+ VScrollbarRenderer { renderVScrollbar = fill '█'+ , renderVScrollbarTrough = fill ' '+ , renderVScrollbarHandleBefore = char '^'+ , renderVScrollbarHandleAfter = char 'v'+ , scrollbarWidthAllocation = 1+ } -- | Enable horizontal scroll bars on all viewports in the specified -- widget and draw them with the specified orientation.@@ -1296,20 +1509,21 @@ -- | Render horizontal viewport scroll bars in the specified widget with -- the specified renderer. This is only needed if you want to override -- the use of the default renderer, 'horizontalScrollbarRenderer'.-withHScrollBarRenderer :: ScrollbarRenderer n -> Widget n -> Widget n+withHScrollBarRenderer :: HScrollbarRenderer n -> Widget n -> Widget n withHScrollBarRenderer r w = Widget (hSize w) (vSize w) $ withReaderT (ctxHScrollBarRendererL .~ Just r) (render w) -- | The default renderer for horizontal viewport scroll bars. Override -- with 'withHScrollBarRenderer'.-horizontalScrollbarRenderer :: ScrollbarRenderer n+horizontalScrollbarRenderer :: HScrollbarRenderer n horizontalScrollbarRenderer =- ScrollbarRenderer { renderScrollbar = fill '█'- , renderScrollbarTrough = fill ' '- , renderScrollbarHandleBefore = str "<"- , renderScrollbarHandleAfter = str ">"- }+ HScrollbarRenderer { renderHScrollbar = fill '█'+ , renderHScrollbarTrough = fill ' '+ , renderHScrollbarHandleBefore = char '<'+ , renderHScrollbarHandleAfter = char '>'+ , scrollbarHeightAllocation = 1+ } -- | Render the specified widget in a named viewport with the -- specified type. This permits widgets to be scrolled without being@@ -1326,11 +1540,11 @@ -- don't like the appearance of the resulting scroll bars (defaults: -- 'verticalScrollbarRenderer' and 'horizontalScrollbarRenderer'), -- you can customize how they are drawn by making your own--- 'ScrollbarRenderer' and using 'withVScrollBarRenderer' and/or--- 'withHScrollBarRenderer'. Note that when you enable scrollbars, the--- content of your viewport will lose one column of available space if--- vertical scroll bars are enabled and one row of available space if--- horizontal scroll bars are enabled.+-- 'VScrollbarRenderer' or 'HScrollbarRenderer' and using+-- 'withVScrollBarRenderer' and/or 'withHScrollBarRenderer'. Note that+-- when you enable scrollbars, the content of your viewport will lose+-- one column of available space if vertical scroll bars are enabled and+-- one row of available space if horizontal scroll bars are enabled. -- -- If a viewport receives more than one visibility request, then the -- visibility requests are merged with the inner visibility request@@ -1394,8 +1608,8 @@ newSize = (newWidth, newHeight) newWidth = c^.availWidthL - vSBWidth newHeight = c^.availHeightL - hSBHeight- vSBWidth = maybe 0 (const 1) vsOrientation- hSBHeight = maybe 0 (const 1) hsOrientation+ vSBWidth = maybe 0 (const $ scrollbarWidthAllocation vsRenderer) vsOrientation+ hSBHeight = maybe 0 (const $ scrollbarHeightAllocation hsRenderer) hsOrientation doInsert (Just vp) = Just $ vp & vpSize .~ newSize doInsert Nothing = Just newVp @@ -1485,17 +1699,21 @@ Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" Just v -> return v - -- Then perform a translation of the sub-rendering to fit into the- -- viewport- translated <- render $ translateBy (Location (-1 * vpFinal^.vpLeft, -1 * vpFinal^.vpTop))- $ Widget Fixed Fixed $ return initialResult+ -- Then crop the sub-rendering to fit into the viewport at the+ -- desired viewport offset.+ translated <- render $ fromJust $+ release $+ cropLeftBy (vpFinal^.vpLeft) $+ cropTopBy (vpFinal^.vpTop) $+ Widget Fixed Fixed $ return initialResult -- If the vertical scroll bar is enabled, render the scroll bar -- area. let addVScrollbar = case vsOrientation of Nothing -> id Just orientation ->- let sb = verticalScrollbar vsRenderer vpname+ let sb = verticalScrollbar vsRenderer orientation+ vpname vsbClickableConstr showVHandles (vpFinal^.vpSize._2)@@ -1508,7 +1726,8 @@ addHScrollbar = case hsOrientation of Nothing -> id Just orientation ->- let sb = horizontalScrollbar hsRenderer vpname+ let sb = horizontalScrollbar hsRenderer orientation+ vpname hsbClickableConstr showHHandles (vpFinal^.vpSize._1)@@ -1527,17 +1746,16 @@ case translatedSize of (0, 0) -> do let spaceFill = V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL)- return $ translated & imageL .~ spaceFill- & visibilityRequestsL .~ mempty- & extentsL .~ mempty+ return $ emptyResult & imageL .~ spaceFill _ -> render $ addVScrollbar $ addHScrollbar $ vLimit (vpFinal^.vpSize._2) $ hLimit (vpFinal^.vpSize._1) $ padBottom Max $ padRight Max- $ Widget Fixed Fixed- $ return $ translated & visibilityRequestsL .~ mempty+ $ Widget Fixed Fixed $+ cropResultToContext =<<+ (cropExtraLayersToContext $ translated & visibilityRequestsL .~ mempty) -- | The base attribute for scroll bars. scrollbarAttr :: AttrName@@ -1562,7 +1780,7 @@ maybeClick _ Nothing _ w = w maybeClick n (Just f) el w = clickable (f el n) w --- | Build a vertical scroll bar using the specified render and+-- | Build a vertical scroll bar using the specified renderer and -- settings. -- -- You probably don't want to use this directly; instead,@@ -1571,8 +1789,13 @@ -- render a scroll bar of your own, you can do so outside the @viewport@ -- context. verticalScrollbar :: (Ord n)- => ScrollbarRenderer n+ => VScrollbarRenderer n -- ^ The renderer to use.+ -> VScrollBarOrientation+ -- ^ The scroll bar orientation. The orientation+ -- governs how additional padding is added to+ -- the scroll bar if it is smaller than it space+ -- allocation according to 'scrollbarWidthAllocation'. -> n -- ^ The viewport name associated with this scroll -- bar.@@ -1587,24 +1810,35 @@ -> Int -- ^ The total viewport content height. -> Widget n-verticalScrollbar vsRenderer n constr False vpHeight vOffset contentHeight =- verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight-verticalScrollbar vsRenderer n constr True vpHeight vOffset contentHeight =- vBox [ maybeClick n constr SBHandleBefore $- hLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleBefore vsRenderer- , verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight- , maybeClick n constr SBHandleAfter $- hLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleAfter vsRenderer- ]+verticalScrollbar vsRenderer o n constr showHandles vpHeight vOffset contentHeight =+ hLimit (scrollbarWidthAllocation vsRenderer) $+ applyPadding $+ if showHandles+ then vBox [ vLimit 1 $+ maybeClick n constr SBHandleBefore $+ withDefAttr scrollbarHandleAttr $ renderVScrollbarHandleBefore vsRenderer+ , sbBody+ , vLimit 1 $+ maybeClick n constr SBHandleAfter $+ withDefAttr scrollbarHandleAttr $ renderVScrollbarHandleAfter vsRenderer+ ]+ else sbBody+ where+ sbBody = verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight+ applyPadding = case o of+ OnLeft -> padRight Max+ OnRight -> padLeft Max verticalScrollbar' :: (Ord n)- => ScrollbarRenderer n+ => VScrollbarRenderer n -- ^ The renderer to use. -> n -- ^ The viewport name associated with this scroll -- bar. -> Maybe (ClickableScrollbarElement -> n -> n)- -- ^ Constructor for clickable scroll bar element names.+ -- ^ Constructor for clickable scroll bar element+ -- names. Will be given the element name and the+ -- viewport name. -> Int -- ^ The total viewport height in effect. -> Int@@ -1613,7 +1847,7 @@ -- ^ The total viewport content height. -> Widget n verticalScrollbar' vsRenderer _ _ vpHeight _ 0 =- hLimit 1 $ vLimit vpHeight $ renderScrollbarTrough vsRenderer+ vLimit vpHeight $ renderVScrollbarTrough vsRenderer verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight = Widget Fixed Greedy $ do c <- getContext@@ -1645,22 +1879,21 @@ sbAbove = maybeClick n constr SBTroughBefore $ withDefAttr scrollbarTroughAttr $ vLimit sbOffset $- renderScrollbarTrough vsRenderer+ renderVScrollbarTrough vsRenderer sbBelow = maybeClick n constr SBTroughAfter $ withDefAttr scrollbarTroughAttr $ vLimit (ctxHeight - (sbOffset + sbSize)) $- renderScrollbarTrough vsRenderer+ renderVScrollbarTrough vsRenderer sbMiddle = maybeClick n constr SBBar $- withDefAttr scrollbarAttr $ vLimit sbSize $ renderScrollbar vsRenderer+ withDefAttr scrollbarAttr $ vLimit sbSize $ renderVScrollbar vsRenderer - sb = hLimit 1 $- if sbSize == ctxHeight+ sb = if sbSize == ctxHeight then vLimit sbSize $- renderScrollbarTrough vsRenderer+ renderVScrollbarTrough vsRenderer else vBox [sbAbove, sbMiddle, sbBelow] render sb --- | Build a horizontal scroll bar using the specified render and+-- | Build a horizontal scroll bar using the specified renderer and -- settings. -- -- You probably don't want to use this directly; instead, use@@ -1669,14 +1902,21 @@ -- render a scroll bar of your own, you can do so outside the @viewport@ -- context. horizontalScrollbar :: (Ord n)- => ScrollbarRenderer n+ => HScrollbarRenderer n -- ^ The renderer to use.+ -> HScrollBarOrientation+ -- ^ The scroll bar orientation. The orientation+ -- governs how additional padding is added+ -- to the scroll bar if it is smaller+ -- than it space allocation according to+ -- 'scrollbarHeightAllocation'. -> n -- ^ The viewport name associated with this scroll -- bar. -> Maybe (ClickableScrollbarElement -> n -> n) -- ^ Constructor for clickable scroll bar element- -- names.+ -- names. Will be given the element name and the+ -- viewport name. -> Bool -- ^ Whether to show handles. -> Int@@ -1686,18 +1926,27 @@ -> Int -- ^ The total viewport content width. -> Widget n-horizontalScrollbar hsRenderer n constr False vpWidth hOffset contentWidth =- horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth-horizontalScrollbar hsRenderer n constr True vpWidth hOffset contentWidth =- hBox [ maybeClick n constr SBHandleBefore $- vLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleBefore hsRenderer- , horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth- , maybeClick n constr SBHandleAfter $- vLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleAfter hsRenderer- ]+horizontalScrollbar hsRenderer o n constr showHandles vpWidth hOffset contentWidth =+ vLimit (scrollbarHeightAllocation hsRenderer) $+ applyPadding $+ if showHandles+ then hBox [ hLimit 1 $+ maybeClick n constr SBHandleBefore $+ withDefAttr scrollbarHandleAttr $ renderHScrollbarHandleBefore hsRenderer+ , sbBody+ , hLimit 1 $+ maybeClick n constr SBHandleAfter $+ withDefAttr scrollbarHandleAttr $ renderHScrollbarHandleAfter hsRenderer+ ]+ else sbBody+ where+ sbBody = horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth+ applyPadding = case o of+ OnTop -> padBottom Max+ OnBottom -> padTop Max horizontalScrollbar' :: (Ord n)- => ScrollbarRenderer n+ => HScrollbarRenderer n -- ^ The renderer to use. -> n -- ^ The viewport name associated with this scroll@@ -1713,7 +1962,7 @@ -- ^ The total viewport content width. -> Widget n horizontalScrollbar' hsRenderer _ _ vpWidth _ 0 =- vLimit 1 $ hLimit vpWidth $ renderScrollbarTrough hsRenderer+ hLimit vpWidth $ renderHScrollbarTrough hsRenderer horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth = Widget Greedy Fixed $ do c <- getContext@@ -1744,17 +1993,16 @@ sbLeft = maybeClick n constr SBTroughBefore $ withDefAttr scrollbarTroughAttr $ hLimit sbOffset $- renderScrollbarTrough hsRenderer+ renderHScrollbarTrough hsRenderer sbRight = maybeClick n constr SBTroughAfter $ withDefAttr scrollbarTroughAttr $ hLimit (ctxWidth - (sbOffset + sbSize)) $- renderScrollbarTrough hsRenderer+ renderHScrollbarTrough hsRenderer sbMiddle = maybeClick n constr SBBar $- withDefAttr scrollbarAttr $ hLimit sbSize $ renderScrollbar hsRenderer+ withDefAttr scrollbarAttr $ hLimit sbSize $ renderHScrollbar hsRenderer - sb = vLimit 1 $- if sbSize == ctxWidth+ sb = if sbSize == ctxWidth then hLimit sbSize $- renderScrollbarTrough hsRenderer+ renderHScrollbarTrough hsRenderer else hBox [sbLeft, sbMiddle, sbRight] render sb
src/Brick/Widgets/Dialog.hs view
@@ -5,21 +5,25 @@ -- dialog title, if any, as well as its body and buttons. -- -- Note that this dialog is really for simple use cases where you want--- to get the user's answer to a question, such as "Would you like--- to save changes before quitting?" If you require something more--- sophisticated, you'll need to build it yourself. You might also--- consider seeing the 'Brick.Forms' module for help with input--- management, and see the implementation of this module to see how to--- reproduce a dialog-style UI.+-- to get the user's answer to a question, such as "Would you like to+-- save changes before quitting?" As is typical in such cases, we assume+-- that this dialog box is used modally, meaning that while it is open+-- it is has exclusive input focus until it is closed.+--+-- If you require something more sophisticated, you'll need to build it+-- yourself. You might also consider seeing the 'Brick.Forms' module for+-- help with input management and see the implementation of this module+-- to see how to reproduce a dialog-style UI. module Brick.Widgets.Dialog ( Dialog , dialogTitle , dialogButtons- , dialogSelectedIndex , dialogWidth -- * Construction and rendering , dialog , renderDialog+ , getDialogFocus+ , setDialogFocus -- * Handling events , handleDialogEvent -- * Getting a dialog's current value@@ -30,20 +34,20 @@ , buttonSelectedAttr -- * Lenses , dialogButtonsL- , dialogSelectedIndexL , dialogWidthL , dialogTitleL ) where import Lens.Micro+import Lens.Micro.Mtl ((%=)) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif-import Data.List (intersperse)+import Data.List (intersperse, find) import Graphics.Vty.Input (Event(..), Key(..)) -import Brick.Util (clamp)+import Brick.Focus import Brick.Types import Brick.Widgets.Core import Brick.Widgets.Center@@ -59,43 +63,55 @@ -- -- * Tab or Right Arrow: select the next button -- * Shift-tab or Left Arrow: select the previous button-data Dialog a =- Dialog { dialogTitle :: Maybe String+data Dialog a n =+ Dialog { dialogTitle :: Maybe (Widget n) -- ^ The dialog title- , dialogButtons :: [(String, a)]- -- ^ The dialog button labels and values- , dialogSelectedIndex :: Maybe Int- -- ^ The currently selected dialog button index (if any)+ , dialogButtons :: [(String, n, a)]+ -- ^ The dialog buttons' labels, resource names, and values , dialogWidth :: Int -- ^ The maximum width of the dialog+ , dialogFocus :: FocusRing n+ -- ^ The focus ring for the dialog's buttons } suffixLenses ''Dialog -handleDialogEvent :: Event -> EventM n (Dialog a) ()+handleDialogEvent :: Event -> EventM n (Dialog a n) () 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- EvKey KLeft [] -> nextButtonBy (-1) False d- _ -> d+ case ev of+ EvKey (KChar '\t') [] -> dialogFocusL %= focusNext+ EvKey KRight [] -> dialogFocusL %= focusNext+ EvKey KBackTab [] -> dialogFocusL %= focusPrev+ EvKey KLeft [] -> dialogFocusL %= focusPrev+ _ -> return () +-- | Set the focused button of a dialog.+setDialogFocus :: (Eq n) => n -> Dialog a n -> Dialog a n+setDialogFocus n d = d { dialogFocus = focusSetCurrent n $ dialogFocus d }++-- | Get the focused button of a dialog.+getDialogFocus :: Dialog a n -> Maybe n+getDialogFocus = focusGetCurrent . dialogFocus+ -- | Create a dialog.-dialog :: Maybe String+dialog :: (Eq n)+ => Maybe (Widget n) -- ^ The dialog title- -> Maybe (Int, [(String, a)])- -- ^ The currently-selected button index (starting at zero) and- -- the button labels and values to use+ -> Maybe (n, [(String, n, a)])+ -- ^ The currently-selected button resource name and the button+ -- labels, resource names, and values to use for each button,+ -- respectively -> Int -- ^ The maximum width of the dialog- -> Dialog a+ -> Dialog a n dialog title buttonData w =- let (buttons, idx) = case buttonData of- Nothing -> ([], Nothing)- Just (_, []) -> ([], Nothing)- Just (i, bs) -> (bs, Just $ clamp 0 (length bs - 1) i)- in Dialog title buttons idx w+ let (r, buttons) = case buttonData of+ Nothing ->+ (focusRing [], [])+ Just (focName, entries) ->+ let ns = (\(_, n, _) -> n) <$> entries+ in (focusSetCurrent focName $ focusRing ns, entries)+ in Dialog title buttons w r -- | The default attribute of the dialog dialogAttr :: AttrName@@ -113,17 +129,25 @@ -- dialog as a layer, which makes this suitable as a top-level layer in -- your rendering function to be rendered on top of the rest of your -- interface.-renderDialog :: Dialog a -> Widget n -> Widget n+renderDialog :: (Ord n) => Dialog a n -> Widget n -> Widget n renderDialog d body = let buttonPadding = str " "- mkButton (i, (s, _)) = let att = if Just i == d^.dialogSelectedIndexL- then buttonSelectedAttr- else buttonAttr- in withAttr att $ str $ " " <> s <> " "+ foc = focusGetCurrent $ dialogFocus d+ mkButton (s, n, _) =+ let att = if Just n == foc+ then buttonSelectedAttr+ else buttonAttr+ csr = if Just n == foc+ then putCursor n (Location (1,0))+ else id+ in csr $+ clickable n $+ withAttr att $+ str $ " " <> s <> " " buttons = hBox $ intersperse buttonPadding $- mkButton <$> (zip [0..] (d^.dialogButtonsL))+ mkButton <$> (d^.dialogButtonsL) - doBorder = maybe border borderWithLabel (str <$> d^.dialogTitleL)+ doBorder = maybe border borderWithLabel (d^.dialogTitleL) in centerLayer $ withDefAttr dialogAttr $ hLimit (d^.dialogWidthL) $@@ -132,24 +156,12 @@ , hCenter buttons ] -nextButtonBy :: Int -> Bool -> Dialog a -> Dialog a-nextButtonBy amt wrapCycle d =- let numButtons = length $ d^.dialogButtonsL- in if numButtons == 0 then d- else case d^.dialogSelectedIndexL of- Nothing -> d & dialogSelectedIndexL .~ (Just 0)- Just i -> d & dialogSelectedIndexL .~ (Just newIndex)- where- addedIndex = i + amt- newIndex = if wrapCycle- then addedIndex `mod` numButtons- else max 0 $ min addedIndex $ numButtons - 1---- | Obtain the value associated with the dialog's currently-selected--- button, if any. This function is probably what you want when someone--- presses 'Enter' in a dialog.-dialogSelection :: Dialog a -> Maybe a-dialogSelection d =- case d^.dialogSelectedIndexL of- Nothing -> Nothing- Just i -> Just $ ((d^.dialogButtonsL) !! i)^._2+-- | Obtain the resource name and value associated with the dialog's+-- currently-selected button, if any. The result of this function is+-- probably what you want when someone presses 'Enter' in a dialog.+dialogSelection :: (Eq n) => Dialog a n -> Maybe (n, a)+dialogSelection d = do+ n' <- focusGetCurrent $ dialogFocus d+ let matches (_, n, _) = n == n'+ (_, n, a) <- find matches (d^.dialogButtonsL)+ return (n, a)
src/Brick/Widgets/Edit.hs view
@@ -169,7 +169,7 @@ -> Editor T.Text n editorText = editor --- | Construct an editor over 'String' values+-- | Construct an editor over generic text values editor :: Z.GenericTextZipper a => n -- ^ The editor's name (must be unique)@@ -188,7 +188,7 @@ -- any edits applied here will be ignored if they edit text outside -- the line limit. applyEdit :: (Z.TextZipper t -> Z.TextZipper t)- -- ^ The 'Data.Text.Zipper' editing transformation to apply+ -- ^ The 'Z.TextZipper' editing transformation to apply -> Editor t n -> Editor t n applyEdit f e = e & editContentsL %~ f@@ -232,13 +232,13 @@ Just lim -> vLimit lim atChar = charAtCursor $ e^.editContentsL atCharWidth = maybe 1 textWidth atChar+ contents = getEditContents e in withAttr (if foc then editFocusedAttr else editAttr) $ limit $ viewport (e^.editorNameL) Both $ (if foc then showCursor (e^.editorNameL) cursorLoc else id) $ visibleRegion cursorLoc (atCharWidth, 1) $- draw $- getEditContents e+ (draw contents) <+> char ' ' charAtCursor :: (Z.GenericTextZipper t) => Z.TextZipper t -> Maybe t charAtCursor z =
src/Brick/Widgets/FileBrowser.hs view
@@ -71,6 +71,7 @@ , actionFileBrowserBeginSearch , actionFileBrowserSelectEnter , actionFileBrowserSelectCurrent+ , actionFileBrowserToggleCurrent , actionFileBrowserListPageUp , actionFileBrowserListPageDown , actionFileBrowserListHalfPageUp@@ -143,9 +144,10 @@ where import qualified Control.Exception as E-import Control.Monad (forM)+import Control.Monad (forM, when) import Control.Monad.IO.Class (liftIO) import Data.Char (toLower, isPrint)+import Data.Foldable (for_) import Data.Maybe (fromMaybe, isJust, fromJust) import qualified Data.Foldable as F import qualified Data.Text as T@@ -153,16 +155,16 @@ import Data.Monoid #endif import Data.Int (Int64)-import Data.List (sortBy, isSuffixOf)+import Data.List (sortBy, isSuffixOf, dropWhileEnd) import qualified Data.Set as Set import qualified Data.Vector as V import Lens.Micro-import Lens.Micro.Mtl ((%=))+import Lens.Micro.Mtl ((%=), use) import Lens.Micro.TH (lensRules, generateUpdateableOptics) import qualified Graphics.Vty as Vty import qualified System.Directory as D-import qualified System.Posix.Files as U-import qualified System.Posix.Types as U+import qualified System.PosixCompat.Files as U+import qualified System.PosixCompat.Types as U import qualified System.FilePath as FP import Text.Printf (printf) @@ -281,7 +283,7 @@ -> IO (FileBrowser n) newFileBrowser selPredicate name mCwd = do initialCwd <- FP.normalise <$> case mCwd of- Just path -> return path+ Just path -> return $ removeTrailingSlash path Nothing -> D.getCurrentDirectory let b = FileBrowser { fileBrowserWorkingDirectory = initialCwd@@ -297,6 +299,22 @@ setWorkingDirectory initialCwd b +-- | Removes any trailing slash(es) from the supplied FilePath (which should+-- indicate a directory). This does not remove a sole slash indicating the root+-- directory.+--+-- This is done because if the FileBrowser is initialized with an initial working+-- directory that ends in a slash, then selecting the "../" entry to move to the+-- parent directory will cause the removal of the trailing slash, but it will not+-- otherwise cause any change, misleading the user into thinking no action was+-- taken (the disappearance of the trailing slash is unlikely to be noticed).+-- All subsequent parent directory selection operations are processed normally,+-- and the 'fileBrowserWorkingDirectory' never ends in a trailing slash+-- thereafter (except at the root directory).+removeTrailingSlash :: FilePath -> FilePath+removeTrailingSlash "/" = "/"+removeTrailingSlash d = dropWhileEnd (== '/') d+ -- | A file entry selector that permits selection of all file entries -- except directories. Use this if you want users to be able to navigate -- directories in the browser. If you want users to be able to select@@ -318,10 +336,7 @@ selectDirectories i = case fileInfoFileType i of Just Directory -> True- Just SymbolicLink ->- case fileInfoLinkTargetType i of- Just Directory -> True- _ -> False+ Just SymbolicLink -> fileInfoLinkTargetType i == Just Directory _ -> False -- | Set the filtering function used to determine which entries in@@ -362,7 +377,7 @@ Left (_::E.IOException) -> entries Right parent -> parent : entries - return $ (setEntries allEntries b)+ return $ setEntries allEntries b & fileBrowserWorkingDirectoryL .~ path & fileBrowserExceptionL .~ exc & fileBrowserSelectedFilesL .~ mempty@@ -492,7 +507,7 @@ applyFilterAndSearch b = let filterMatch = fromMaybe (const True) (b^.fileBrowserEntryFilterL) searchMatch = maybe (const True)- (\search i -> (T.toLower search `T.isInfixOf` (T.pack $ toLower <$> fileInfoSanitizedFilename i)))+ (\search i -> T.toLower search `T.isInfixOf` T.pack (toLower <$> fileInfoSanitizedFilename i)) (b^.fileBrowserSearchStringL) match i = filterMatch i && searchMatch i matching = filter match $ b^.fileBrowserLatestResultsL@@ -588,7 +603,7 @@ -- -- * @/@: 'actionFileBrowserBeginSearch' -- * @Enter@: 'actionFileBrowserSelectEnter'--- * @Space@: 'actionFileBrowserSelectCurrent'+-- * @Space@: 'actionFileBrowserToggleCurrent' -- * @g@: 'actionFileBrowserListTop' -- * @G@: 'actionFileBrowserListBottom' -- * @j@: 'actionFileBrowserListNext'@@ -611,6 +626,10 @@ actionFileBrowserSelectCurrent = selectCurrentEntry +actionFileBrowserToggleCurrent :: EventM n (FileBrowser n) ()+actionFileBrowserToggleCurrent =+ toggleCurrentEntrySelected+ actionFileBrowserListPageUp :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListPageUp = zoom fileBrowserEntriesL listMovePageUp@@ -683,8 +702,8 @@ -- Select file or enter directory actionFileBrowserSelectEnter Vty.EvKey (Vty.KChar ' ') [] ->- -- Select entry- actionFileBrowserSelectCurrent+ -- Toggle selected status of current entry+ actionFileBrowserToggleCurrent _ -> handleFileBrowserEventCommon e @@ -714,6 +733,29 @@ _ -> zoom fileBrowserEntriesL $ handleListEvent e +toggleSelected :: FileInfo -> EventM n (FileBrowser n) ()+toggleSelected e = do+ sel <- fileBrowserIsSelected e+ if sel+ then fileBrowserRemoveSelected e+ else fileBrowserAddSelected e++fileBrowserIsSelected :: FileInfo -> EventM n (FileBrowser n) Bool+fileBrowserIsSelected e = do+ fs <- use fileBrowserSelectedFilesL+ let fName = fileInfoFilename e+ return $ Set.member fName fs++fileBrowserAddSelected :: FileInfo -> EventM n (FileBrowser n) ()+fileBrowserAddSelected e = do+ let fName = fileInfoFilename e+ fileBrowserSelectedFilesL %= Set.insert fName++fileBrowserRemoveSelected :: FileInfo -> EventM n (FileBrowser n) ()+fileBrowserRemoveSelected e = do+ let fName = fileInfoFilename e+ fileBrowserSelectedFilesL %= Set.delete fName+ -- | If the browser's current entry is selectable according to -- @fileBrowserSelectable@, add it to the selection set and return. -- If not, and if the entry is a directory or a symlink targeting a@@ -723,30 +765,26 @@ maybeSelectCurrentEntry :: EventM n (FileBrowser n) () maybeSelectCurrentEntry = do b <- get- case fileBrowserCursor b of- Nothing -> return ()- Just entry ->- if fileBrowserSelectable b entry- then fileBrowserSelectedFilesL %= Set.insert (fileInfoFilename entry)- else case fileInfoFileType entry of- Just Directory ->- put =<< (liftIO $ setWorkingDirectory (fileInfoFilePath entry) b)- Just SymbolicLink ->- case fileInfoLinkTargetType entry of- Just Directory ->- put =<< (liftIO $ setWorkingDirectory (fileInfoFilePath entry) b)- _ ->- return ()- _ ->- return ()+ for_ (fileBrowserCursor b) $ \entry ->+ if fileBrowserSelectable b entry+ then fileBrowserAddSelected entry+ else when (selectDirectories entry) $+ put =<< liftIO (setWorkingDirectory (fileInfoFilePath entry) b) selectCurrentEntry :: EventM n (FileBrowser n) () selectCurrentEntry = do b <- get- case fileBrowserCursor b of- Nothing -> return ()- Just e -> fileBrowserSelectedFilesL %= Set.insert (fileInfoFilename e)+ for_ (fileBrowserCursor b) $ \entry ->+ when (fileBrowserSelectable b entry) $+ fileBrowserAddSelected entry +toggleCurrentEntrySelected :: EventM n (FileBrowser n) ()+toggleCurrentEntrySelected = do+ b <- get+ for_ (fileBrowserCursor b) $ \entry ->+ when (fileBrowserSelectable b entry) $+ toggleSelected entry+ -- | Render a file browser. This renders a list of entries in the -- working directory, a cursor to select from among the entries, a -- header displaying the working directory, and a footer displaying@@ -765,7 +803,7 @@ -- ^ The browser to render. -> Widget n renderFileBrowser foc b =- let maxFilenameLength = maximum $ (length . fileInfoFilename) <$> (b^.fileBrowserEntriesL)+ let maxFilenameLength = maximum $ length . fileInfoFilename <$> (b^.fileBrowserEntriesL) cwdHeader = padRight Max $ str $ sanitizeFilename $ fileBrowserWorkingDirectory b selInfo = case listSelectedElement (b^.fileBrowserEntriesL) of@@ -789,7 +827,7 @@ then ", " <> prettyFileSize (fileStatusSize stat) else "" in fileTypeLabel (fileStatusFileType stat) <> maybeSize- in txt $ (T.pack $ fileInfoSanitizedFilename i) <> ": " <> label+ in txt $ T.pack (fileInfoSanitizedFilename i) <> ": " <> label maybeSearchInfo = case b^.fileBrowserSearchStringL of Nothing -> emptyWidget
src/Brick/Widgets/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} module Brick.Widgets.Internal ( renderFinal , cropToContext@@ -8,10 +9,14 @@ ) where -import Lens.Micro ((^.), (&), (%~))+import Lens.Micro ((^.), (&), (%~), (.~)) import Lens.Micro.Mtl ((%=))+import Control.Monad import Control.Monad.State.Strict import Control.Monad.Reader+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import qualified Data.Traversable as T import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S@@ -30,19 +35,93 @@ -> V.DisplayRegion -> ([CursorLocation n] -> Maybe (CursorLocation n)) -> RenderState n- -> (RenderState n, V.Picture, Maybe (CursorLocation n), [Extent n])+ -> (RenderState n, V.Picture, Maybe (CursorLocation n), [LayerExtents n]) renderFinal aMap layerRenders (w, h) chooseCursor rs =- (newRS, picWithBg, theCursor, concat layerExtents)+ (newRS, picWithBg, theCursor, F.toList layerExtents) where- (layerResults, !newRS) = flip runState rs $ sequence $- (\p -> runReaderT p ctx) <$>- (\layerWidget -> do- result <- render $ cropToContext layerWidget- forM_ (result^.extentsL) $ \e ->- reportedExtentsL %= M.insert (extentName e) e- return result- ) <$> reverse layerRenders+ -- Reset various fields from the last rendering state so they+ -- don't accumulate or affect this rendering.+ resetRs = rs & reportedExtentsL .~ mempty+ & observedNamesL .~ mempty+ & clickableNamesL .~ mempty + (allLayers, !newRS) = flip runState resetRs $ do+ go $ Seq.fromList layerRenders+ where+ go layers =+ case Seq.viewr layers of+ Seq.EmptyR -> return mempty+ rest Seq.:> next -> do+ thisLayerResults <- flip runReaderT ctx $+ processMainLayer next++ restResults <- go rest+ return $ restResults <> thisLayerResults++ processMainLayer layerWidget = do+ let recordExtents r =+ forM_ (r^.extentsL) $ \e ->+ reportedExtentsL %= M.insert (extentName e) e++ -- Keep track of the rendered result prior to+ -- translation so we can record its size. Once+ -- translated, its size will be the size of the+ -- display region, but we need the original+ -- untranslated size so we can keep track of layer+ -- extents for click events.+ preTranslation <- render $ cropToContext layerWidget+ let result = translateResult preTranslation+ recordExtents result++ let gatherLayer r = do+ let r' = translateResult r+ recordExtents r'++ rest <- T.mapM gatherLayer $ r'^.extraLayersL+ return $ concatSeq rest Seq.|> (resultSize r, r')++ translatedLayerResults <- T.mapM gatherLayer $ result^.extraLayersL+ return $ concatSeq translatedLayerResults Seq.|> (resultSize preTranslation, result)++ getTranslationOffset r =+ let originalOffset = translationOffset r+ correction = getTranslationCorrection r+ in originalOffset <> correction++ getTranslationCorrection r =+ let Location (hOff, vOff) = translationOffset r+ rWidth = V.imageWidth (r^.imageL)+ rHeight = V.imageHeight (r^.imageL)+ colCorrection = if hOff < 0+ then abs hOff+ else if hOff + rWidth > w+ then w - (hOff + rWidth)+ else 0+ rowCorrection = if vOff < 0+ then abs vOff+ else if vOff + rHeight > h+ then h - (vOff + rHeight)+ else 0+ hCorrection = case horizontalClampPolicy r of+ Truncate -> Location (0, 0)+ Reposition -> Location (colCorrection, 0)+ vCorrection = case verticalClampPolicy r of+ Truncate -> Location (0, 0)+ Reposition -> Location (0, rowCorrection)+ in hCorrection <> vCorrection++ translateResult r =+ let off = getTranslationOffset r+ in addResultOffset off $+ r & imageL %~ (V.translate (off^.locationColumnL) (off^.locationRowL))++ resultSize r = (V.imageWidth i, V.imageHeight i)+ where+ i = r^.imageL++ concatSeq ss =+ F.foldr (Seq.><) Seq.empty ss+ ctx = Context { ctxAttrName = mempty , availWidth = w , availHeight = h@@ -50,6 +129,7 @@ , windowHeight = h , ctxBorderStyle = defaultBorderStyle , ctxAttrMap = aMap+ , ctxOrigAttrMap = aMap , ctxDynBorders = False , ctxVScrollBarOrientation = Nothing , ctxVScrollBarRenderer = Nothing@@ -61,16 +141,21 @@ , ctxVScrollBarClickableConstr = Nothing } - layersTopmostFirst = reverse layerResults- pic = V.picForLayers $ V.resize w h <$> (^.imageL) <$> layersTopmostFirst+ pic = V.picForLayers $ F.toList $ V.resize w h <$> (^.imageL) <$> snd <$> allLayers -- picWithBg is a workaround for runaway attributes. -- See https://github.com/coreyoconnor/vty/issues/95 picWithBg = pic { V.picBackground = V.Background ' ' V.defAttr } - layerCursors = (^.cursorsL) <$> layersTopmostFirst- layerExtents = reverse $ (^.extentsL) <$> layersTopmostFirst- theCursor = chooseCursor $ concat layerCursors+ (layerCursors, layerExtents) = Seq.unzipWith layerInfo allLayers+ layerInfo (untranslatedSize, l) = (l^.cursorsL, mkLayerExtents untranslatedSize l)+ mkLayerExtents untranslatedSize l =+ -- The size of a layer is its size prior to translation,+ -- since measuring the layer's image size after translation+ -- will give a size much bigger than the size of the layer's+ -- apparent visual area.+ LayerExtents (l^.translationOffsetL) untranslatedSize $ l^.extentsL+ theCursor = chooseCursor $ concat $ F.toList layerCursors -- | After rendering the specified widget, crop its result image to the -- dimensions in the rendering context.@@ -106,29 +191,31 @@ cropExtents :: Context n -> [Extent n] -> [Extent n] cropExtents ctx es = mapMaybe cropExtent es where- -- An extent is cropped in places where it is not within the- -- region described by the context.- --- -- If its entirety is outside the context region, it is dropped.- --- -- Otherwise its size is adjusted so that it is contained within- -- the context region. cropExtent (Extent n (Location (c, r)) (w, h)) =- -- Determine the new lower-right corner- let endCol = c + w- endRow = r + h- -- Then clamp the lower-right corner based on the- -- context- endCol' = min (ctx^.availWidthL) endCol- endRow' = min (ctx^.availHeightL) endRow- -- Then compute the new width and height from the- -- clamped lower-right corner.- w' = endCol' - c- h' = endRow' - r- e = Extent n (Location (c, r)) (w', h')- in if w' < 0 || h' < 0- then Nothing- else Just e+ -- Clamp the original extent's UL corner to the context.+ --+ -- Clamp the original extent's LR corner to the context.+ --+ -- Keep the modified extent (i.e. with clamped corners)+ -- only if the resulting extent has non-zero size in both+ -- dimensions.+ let nonEmpty = nonEmptyH && nonEmptyV+ nonEmptyH = newWidth > 0+ nonEmptyV = newHeight > 0+ newWidth = newEndCol - newStartCol+ newHeight = newEndRow - newStartRow+ (newStartCol, newStartRow) = clampCorner (c, r)+ (newEndCol, newEndRow) = clampCorner (c + w, r + h)+ clampCorner (cols, rows) =+ ( clampRange (ctx^.availWidthL) cols+ , clampRange (ctx^.availHeightL) rows+ )+ clampRange bound val =+ min bound $ max 0 val+ newExtent = Extent n (Location (newStartCol, newStartRow)) (newWidth, newHeight)+ in if nonEmpty+ then Just newExtent+ else Nothing cropBorders :: Context n -> BorderMap DynBorder -> BorderMap DynBorder cropBorders ctx = BM.crop Edges@@ -182,7 +269,7 @@ , rsScrollRequests = [] , observedNames = S.empty , renderCache = mempty- , clickableNames = []+ , clickableNames = mempty , requestedVisibleNames_ = S.empty , reportedExtents = mempty }
src/Brick/Widgets/List.hs view
@@ -1,20 +1,18 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-}--- | This module provides a scrollable list type and functions for--- manipulating and rendering it.+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+-- | This module provides a scrollable list type. ----- Note that lenses are provided for direct manipulation purposes, but--- lenses are *not* safe and should be used with care. (For example,--- 'listElementsL' permits direct manipulation of the list container--- without performing bounds checking on the selected index.) If you--- need a safe API, consider one of the various functions for list--- manipulation. For example, instead of 'listElementsL', consider--- 'listReplace'.+-- Note that some lenses are provided for direct manipulation purposes,+-- but not all lenses are safe to use since misuse can violate+-- invariants. (For example, 'listElementsL' permits direct manipulation+-- of the list container without performing bounds checking on the+-- selected index.) If you need a safe API, consider one of the+-- various functions for list manipulation. For example, instead of+-- 'listElementsL', consider 'listReplace'. module Brick.Widgets.List ( GenericList , List@@ -22,6 +20,11 @@ -- * Constructing a list , list + -- * Configuring wrapping+ , setScrollWrap+ , getScrollWrap+ , listScrollWrapL+ -- * Rendering a list , renderList , renderListWithIndex@@ -63,6 +66,9 @@ , listReverse , listModify + -- * Querying a list+ , listFindFirst+ -- * Attributes , listAttr , listSelectedAttr@@ -100,8 +106,8 @@ import Brick.AttrMap -- | List state. Lists have a container @t@ of element type @e@ that is--- the data stored by the list. Internally, Lists handle the following--- events by default:+-- the data stored by the list. When using the event-handling functions+-- provided by this module, Lists handle the following events: -- -- * Up/down arrow keys: move cursor of selected item -- * Page up / page down keys: move cursor of selected item by one page@@ -109,6 +115,15 @@ -- * Home/end keys: move cursor of selected item to beginning or end of -- list --+-- Movement key behaviors (and their corresponding list transformation+-- functions) are subject to wrapping if the list's wrapping is enabled;+-- in that case, attempts to move the selection beyond either end of the+-- list will wrap the selection to the opposite end of the list. When+-- wrapping is disabled, attempts to move beyond either end of the list+-- will move the selection as far as possible without wrapping around+-- to the opposite end. To control whether wrapping is enabled, see+-- 'setScrollWrap'.+-- -- The 'List' type synonym fixes @t@ to 'V.Vector' for compatibility -- with previous versions of this library. --@@ -120,7 +135,6 @@ -- * 'listRemove': 'Semigroup' -- * 'listClear': 'Monoid' -- * 'listReverse': 'Reversible'--- data GenericList n t e = List { listElements :: !(t e) -- ^ The list's sequence of elements.@@ -130,6 +144,9 @@ -- ^ The list's name. , listItemHeight :: Int -- ^ The height of an individual item in the list.+ , listScrollWrap :: Bool+ -- ^ Whether moving beyond a list's first/last element+ -- should wrap to the last/first element. } deriving (Functor, Foldable, Traversable, Show, Generic) suffixLenses ''GenericList@@ -204,9 +221,9 @@ _ -> return () -- | Enable list movement with the vi keys with a fallback handler if--- none match. Use 'handleListEventVi' 'handleListEvent' in place of--- 'handleListEvent' to add the vi keys bindings to the standard ones.--- Movements handled include:+-- none match. Use 'handleListEventVi' in place of 'handleListEvent'+-- to add the vi keys bindings to the standard ones. Movements handled+-- include: -- -- * Up (k) -- * Down (j)@@ -260,7 +277,8 @@ listSelectedFocusedAttr :: AttrName listSelectedFocusedAttr = listSelectedAttr <> attrName "focused" --- | Construct a list in terms of container 't' with element type 'e'.+-- | Construct a list, with wrapping initially disabled, in terms of+-- container 't' with element type 'e'. list :: (Foldable t) => n -- ^ The list name (must be unique)@@ -273,7 +291,7 @@ list name es h = let selIndex = if null es then Nothing else Just 0 safeHeight = max 1 h- in List es selIndex name safeHeight+ in List es selIndex name safeHeight False -- | Render a list using the specified item drawing function. --@@ -379,7 +397,7 @@ in makeVisible elemWidget render $ viewport (l^.listNameL) Vertical $- translateBy (Location (0, off)) $+ padTop (Pad off) $ vBox $ toList drawnElements -- | Insert an item into a list at the specified position.@@ -462,8 +480,8 @@ | otherwise = 0 in l' & listSelectedL .~ newSel --- | Move the list selected index up by one. (Moves the cursor up,--- subtracts one from the index.)+-- | Move the list selected index up by one (moves the cursor up,+-- subtracts one from the index), subject to wrapping. listMoveUp :: (Foldable t, Splittable t) => GenericList n t e -> GenericList n t e@@ -474,8 +492,8 @@ => EventM n (GenericList n t e) () listMovePageUp = listMoveByPages (-1::Double) --- | Move the list selected index down by one. (Moves the cursor down,--- adds one to the index.)+-- | Move the list selected index down by one (moves the cursor down,+-- adds one to the index), subject to wrapping. listMoveDown :: (Foldable t, Splittable t) => GenericList n t e -> GenericList n t e@@ -486,7 +504,8 @@ => EventM n (GenericList n t e) () listMovePageDown = listMoveByPages (1::Double) --- | Move the list selected index by some (fractional) number of pages.+-- | Move the list selected index by some (fractional) number of pages,+-- subject to wrapping. listMoveByPages :: (Foldable t, Splittable t, Ord n, RealFrac m) => m -> EventM n (GenericList n t e) ()@@ -503,8 +522,9 @@ -- | Move the list selected index. -- -- If the current selection is @Just x@, the selection is adjusted by--- the specified amount. The value is clamped to the extents of the list--- (i.e. the selection does not "wrap").+-- the specified amount. Whether the value is clamped to the extents of the+-- list or not (i.e. whether the selection doesn't wrap around the list or it+-- does), is determined by the list itself (see 'GenericList' for more info). -- -- If the current selection is @Nothing@ (i.e. there is no selection) -- and the direction is positive, set to @Just 0@ (first element),@@ -525,7 +545,10 @@ Nothing | amt > 0 -> 0 | otherwise -> length l - 1- Just i -> max 0 (amt + i) -- don't be negative+ Just i+ | let wrap = l ^. listScrollWrapL+ , wrap -> (amt + i) `mod` length l+ | otherwise -> max 0 (amt + i) -- don't be negative in listMoveTo target l -- | Set the selected index for a list to the specified index, subject@@ -578,6 +601,20 @@ -> GenericList n t e listMoveToElement e = listFindBy (== e) . set listSelectedL Nothing +-- | Find the first element in the list that satisfies the specified+-- predicate. If such an element is found, return the resulting index+-- and element.+--+-- /O(n)/.+listFindFirst :: (Semigroup (t e), Splittable t, Traversable t)+ => (e -> Bool)+ -> GenericList n t e+ -> Maybe (Int, e)+listFindFirst f l =+ listSelectedElement $+ listFindBy f $+ set listSelectedL Nothing l+ -- | Starting from the currently-selected position, attempt to find -- and select the next element matching the predicate. If there are no -- matches for the remainder of the list or if the list has no selection@@ -606,7 +643,6 @@ -- 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 =@@ -657,8 +693,8 @@ l & listElementsL %~ reverse & listSelectedL %~ fmap (length l - 1 -) --- | Apply a function to the selected element. If no element is selected--- the list is not modified.+-- | Apply a function to the selected element. If no element is+-- selected, the list is not modified. -- -- Complexity: same as 'traverse' for the container type (typically -- /O(n)/).@@ -669,9 +705,19 @@ -- 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 = listSelectedElementL %~ f++-- | Sets the list's wrapping behavior; wrapping is enabled if given+-- @True@, or disabled if given @False@.+setScrollWrap :: (Traversable t, Splittable t, Semigroup (t e))+ => Bool -> GenericList n t e -> GenericList n t e+setScrollWrap b = listScrollWrapL .~ b++-- | Returns the list's wrapping setting; returns @True@ if wrapping is+-- enabled or @False@ otherwise.+getScrollWrap :: GenericList n t e -> Bool+getScrollWrap = listScrollWrap
+ src/Brick/Widgets/Menu.hs view
@@ -0,0 +1,1015 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+-- | This module provides a menu widget that is similar to the ones+-- commonly found in most graphical interface toolkits. Menus carry+-- entries that can be activated with the mouse and keyboard and invoke+-- event handlers that you specify when creating the menus and entries.+--+-- = General Information+--+-- Menus carry a sequence of /items/, expressed by the 'MenuItem' type.+-- Items can be:+--+-- * /entries/ - named menu items that can be activated with the+-- keyboard or mouse+-- * /submenus/ - entries that contain nested menus+-- * /separators/ - horizontal lines dividing up groups of other+-- entries+-- * /gaps/ - vertical space between items+--+-- Menu /entries/ can be either enabled or disabled; their status in+-- this regard is determined by invoking a function of type @s -> Bool@+-- at rendering and event-handling time.+--+-- Menus and submenus support both mouse and keyboard interaction. See+-- 'handleMenuEvent' for details.+--+-- Menus have an orientation that can be changed with+-- 'setMenuOrientation' to suit different writing systems. This affects+-- how entries and submenus are rendered and how left/right arrow keys+-- navigate submenus.+--+-- = Use Cases+--+-- This module provides a fully general 'Menu' type and a few+-- specialized menu types for common menu use cases:+--+-- * 'SimpleMenu': a menu with entries that have 'EventM' handlers.+-- Create one of these with 'simpleMenu'. This is a good starting point.+-- * 'DispatchingMenu': a menu whose entries correspond to abstract key+-- events bound to keys by a 'KeyDispatcher'. Create one of these with+-- 'menuWithDispatcher'. This is a good choice when you already have a+-- 'KeyDispatcher' set up and would like menu entries to be triggered+-- by the rebindable keys that trigger the dispatcher's handlers.+-- * 'Menu': the fully general type for menus. Create one of these with+-- 'menu'.+--+-- Depending on the type of menu you're creating, different item+-- constructors may apply. See the 'MenuItem' type aliases since their+-- naming convention follows that of the menu types.+--+-- See the @MenuDemo@ and @MenuKeybindingsDemo@ demonstration programs+-- for complete working examples of using this API.+--+-- = Adding Menus to An Application+--+-- To use this module in an application:+--+-- * Choose a menu type that you want to work with such as 'SimpleMenu'.+-- * For each menu that you want to host, add an application state field+-- and lens for a value of the menu's type, and add a constructor+-- to the application's resource name type, with an argument of+-- type 'MenuRegion'. Add lenses to the application state type with+-- 'Lens.Micro.TH.makeLenses'.+-- * Populate the application's initial state with the menus.+-- * Render menus with 'renderMenu'.+-- * Handle incoming events first with 'handleMenuEvent', and when+-- 'handleMenuEvent' returns @False@, pass unhandled events on to the+-- existing application event handler.+-- * As desired, add entries to the application's 'AttrMap' for the+-- attributes used in this module.+--+-- Use 'Brick.Widgets.MenuBar.MenuBar' if you want to host more than one+-- menu in a group.+--+-- = Handling Events+--+-- Menu events are handled with 'handleMenuEvent', and any unhandled+-- events should be deferred to the application's event handler.+--+-- To support mouse events, each menu must be identified by a unique+-- resource name; this is done by providing a resource name constructor+-- when creating each menu. The application's name type must provide a+-- constructor of type @MenuRegion -> n@ to uniquely identify the menu+-- and its constituent parts. For example, if the application's resource+-- name type is as follows,+--+-- @+-- data Name = Editor1 | Editor2+-- @+--+-- It would need to be modified so that a new data constructor (e.g.+-- @FileMenu@) could be given to the menu constuctors:+--+-- @+-- data Name = Editor1 | Editor2 | FileMenu MenuRegion+-- @+module Brick.Widgets.Menu+ ( Menu+ , menuIsOpen+ , menuContentWidth+ , menuTitleName+ , MenuRegion(..)+ , MenuOrientation(..)+ , openMenu+ , closeMenu+ , toggleMenu++ -- * Constructing menus and items+ , menu+ , MenuItem+ , menuEntry+ , menuSeparator+ , menuGap+ , submenu++ -- * Configuring menus+ , setDefaultEntryRenderer+ , setTitleRenderer+ , titleHightlightKey+ , setMenuOrientation++ -- * Configuring menu items+ , setEnabledWith+ , setEntryRenderer++ -- * Menus with EventM handlers+ , SimpleMenu+ , SimpleMenuItem+ , simpleMenu++ -- * Menus with custom keybindings+ , DispatchingMenu+ , DispatchingMenuItem+ , EntryTrigger(..)+ , menuWithDispatcher+ , menuEntryForKey+ , menuEntryForEvent+ , menuEntryForAction+ , entryWithKeybinding++ -- * Handling events+ , handleMenuEvent++ -- * Rendering menus+ , renderMenu++ -- * Attributes+ , menuAttr+ , menuTitleAttr+ , menuTitleSelectedAttr+ , menuTitleKeyHighlightAttr+ , menuBodyAttr+ , menuEntryDisabledAttr+ , menuEntrySelectedAttr+ , menuEntrySelectedDisabledAttr+ , menuEntryKeybindingAttr+ )+where++import Control.Monad (when)++import Lens.Micro.Platform ((^.), (^?), (.~), (%~), (&), Traversal', ix, each)+import Lens.Micro.Mtl++import Data.Char (toLower)+import qualified Data.Foldable as F+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Maybe (listToMaybe, fromMaybe)++import qualified Graphics.Vty as Vty++import Brick.AttrMap+import Brick.Types+import Brick.Widgets.Border+import Brick.Widgets.Core++import Brick.Keybindings.KeyDispatcher+import Brick.Keybindings.KeyConfig+import Brick.Keybindings.Pretty++-- | The type of menu regions for embedding in the application's+-- resource name and reporting mouse click events.+data MenuRegion =+ MenuTitle+ -- ^ The region of a menu's title+ | MenuBody+ -- ^ The region of a menu's body+ | MenuItemAt Int+ -- ^ The region of the menu item at the specified index+ deriving (Ord, Show, Eq)++-- | Orientation for menu contents.+data MenuOrientation =+ LeftToRight+ -- ^ Menu entries are laid out with labels on the left and submenus+ -- opening to the right+ | RightToLeft+ -- ^ Menu entries are laid out with labels on the right and submenus+ -- opening to the left+ deriving (Ord, Show, Eq)++-- | The general menu type.+--+-- Menus and their items are parameterized on three types:+--+-- * @s@: the application state type used in the @App@ type,+-- * @n@: the application resource name type used in the application's+-- @Widget@ type, and+-- * @k@: the type of data carried and handled by the menu's event+-- handler when a menu entry has been activated.+--+-- Menus contain a sequence of items of type 'MenuItem'. See the+-- documentation above and the constructors for both menus and menu+-- items to create menus.+--+-- A menu is either /open/, in which case its contents are being shown+-- in a floating layer above the application's UI and it is responding+-- to events that manipulate the menu's selected entry, or it is+-- /closed/, in which case its contents are not shown and it is not+-- responding to events other than mouse clicks on its title. The menu's+-- open/closed state is affected by calls to 'openMenu', 'closeMenu',+-- and mouse click events on the menu's title.+--+-- At any given time, a menu may or may not have a currently-selected+-- entry. See 'handleMenuEvent' for details on how keyboard and mouse+-- events influence the choice and behavior of the selected entry. When+-- an entry is selected, it can be /activated/ by an @Enter@ keypress or+-- a mouse click. When activated, its event data is used to invoke the+-- menu's event handler.+--+-- To support mouse events, each menu must be identified by a unique+-- resource name; this is done by providing a resource name constructor+-- when creating each menu. The application's name type must provide a+-- constructor of type @MenuRegion -> n@ to uniquely identify the menu+-- and its constituent parts.+--+-- A menu carries an event handler that will be invoked by+-- 'handleMenuEvent' whenever a menu entry is selected.+data Menu s n k =+ Menu { menuTitle :: !T.Text+ -- ^ The menu's title+ , menuTitleRenderer :: s -> T.Text -> Widget n+ -- ^ The renderer for the menu's title+ , menuItems :: !(V.Vector (MenuItem s n k))+ -- ^ The contents of the menu+ , menuIsOpen :: !Bool+ -- ^ Whether the menu is open.+ , menuContentWidth :: !Int+ -- ^ The width of the menu's items within the enclosing border.+ -- This is a record accessor so it can also be used to change+ -- the menu's width.+ , menuTitleName :: !n+ -- ^ The resource name for this menu's title for generating and+ -- detecting mouse click events+ , menuRegionNameBuilder :: MenuRegion -> n+ -- ^ A function to build resource names for clickable regions+ , menuSelectedIndex :: !(Maybe Int)+ -- ^ State for tracking the selected item index, if any+ , menuEventHandler :: k -> EventM n s ()+ -- ^ Handler to be invoked when an entry in this menu is+ -- activated+ , menuFallbackEventHandler :: Vty.Key -> [Vty.Modifier] -> EventM n s Bool+ -- ^ Handler for key events that weren't handled by+ -- 'handleMenuEvent'+ , menuEntryDefaultRenderer :: MenuOrientation -> k -> T.Text -> Widget n+ -- ^ The function to render entries in this menu+ , menuOrientation :: !MenuOrientation+ -- ^ The layout orientation of the menu's contents+ }++-- | The type of menu items.+data MenuItem s n k =+ MISeparator+ -- ^ A horizontal border between menu items+ | MIGap+ -- ^ An empty line between menu items+ | MIEntry !(MenuEntry s n k)+ -- ^ A labeled menu entry that can be activated with the mouse or by+ -- a keypress+ | MISubmenu !(Menu s n k)+ -- ^ A submenu++-- | A labeled menu entry that can be activated with the mouse or by a+-- keypress.+data MenuEntry s n k =+ MenuEntry { menuEntryLabel :: !T.Text+ -- ^ The menu entry's label+ , menuEntryEnabled :: s -> Bool+ -- ^ The function to determine whether this menu entry is+ -- enabled+ , menuEntryEvent :: !k+ -- ^ The event to generate when this entry is activated+ , menuEntryRenderer :: Maybe (MenuOrientation -> k -> T.Text -> Widget n)+ -- ^ This menu entry's renderer+ }++suffixLenses ''Menu++-- | Set the menu's content orientation, including the orientation of+-- all of its submenus.+setMenuOrientation :: MenuOrientation -> Menu s n k -> Menu s n k+setMenuOrientation o m =+ m & menuOrientationL .~ o+ & menuItemsL.each._Submenu %~ setMenuOrientation o++-- | Set this menu entry's function used to check for its enabled state.+-- This is equivalent to 'id' for non-entry items.+setEnabledWith :: (s -> Bool) -> MenuItem s n k -> MenuItem s n k+setEnabledWith f = mapMenuEntry (\e -> e { menuEntryEnabled = f })++-- | Set this menu entry's rendering function, overriding the menu's+-- default rendering behavior for this entry. This is equivalent to 'id'+-- for non-entry items.+setEntryRenderer :: (MenuOrientation -> k -> T.Text -> Widget n) -> MenuItem s n k -> MenuItem s n k+setEntryRenderer f = mapMenuEntry (\e -> e { menuEntryRenderer = Just f })++-- | Set this menu's entry rendering function.+setDefaultEntryRenderer :: (MenuOrientation -> k -> T.Text -> Widget n) -> Menu s n k -> Menu s n k+setDefaultEntryRenderer f m = m { menuEntryDefaultRenderer = f }++-- | Set this menu's title renderer.+setTitleRenderer :: (s -> T.Text -> Widget n) -> Menu s n k -> Menu s n k+setTitleRenderer f m = m { menuTitleRenderer = f }++mapMenuEntry :: (MenuEntry s n k -> MenuEntry s n k) -> MenuItem s n k -> MenuItem s n k+mapMenuEntry f (MIEntry e) = MIEntry $ f e+mapMenuEntry _ e = e++-- | A separator between menu items.+menuSeparator :: MenuItem s n k+menuSeparator = MISeparator++-- | A gap between menu items.+menuGap :: MenuItem s n k+menuGap = MIGap++-- | A submenu. The menu's title will be used as the submenu's label in+-- its parent menu.+submenu :: Menu s n k -> MenuItem s n k+submenu = MISubmenu++-- | Create a menu entry with the specified label and event data.+-- When the entry is activated, its event data will be passed to the+-- event handler of the enclosing menu.+--+-- By default, this entry has no custom renderer so its appearance is+-- determined by the default entry renderer of the enclosing menu.+-- To change either of these behaviors, use 'setEntryRenderer' or+-- 'setDefaultEntryRenderer'.+--+-- By default, this entry is always enabled regardless of the+-- application state. To change this, use 'setEnabledWith'.+--+-- This is the fully general entry constructor. For more specific use+-- cases, see the other 'MenuItem' constructors in this module.+menuEntry :: T.Text+ -- ^ The menu entry's label+ -> k+ -- ^ The event data carried by the menu entry that will be+ -- passed to the enclosing menu's event handler when this+ -- entry is activated+ -> MenuItem s n k+menuEntry label ev =+ MIEntry $ MenuEntry { menuEntryLabel = label+ , menuEntryEnabled = const True+ , menuEntryEvent = ev+ , menuEntryRenderer = Nothing+ }++-- | A specialization of 'Menu' that has 'EventM' handlers in each menu+-- entry that are evaluated whenever the entries are activated. Create+-- one of these with 'simpleMenu'.+type SimpleMenu s n = Menu s n (EventM n s ())++-- | A specialization of 'MenuItem' for 'SimpleMenu'. Create these with+-- 'menuGap', 'menuSeparator', 'submenu', and 'menuEntry'.+type SimpleMenuItem s n = MenuItem s n (EventM n s ())++-- | Create a 'SimpleMenu' whose entries carry ordinary 'EventM'+-- handlers that are evaluated whenever the menu's entries are+-- activated.+simpleMenu :: T.Text+ -- ^ The menu's title+ -> (MenuRegion -> n)+ -- ^ The menu's resource name constructor+ -> [SimpleMenuItem s n]+ -- ^ The items in this menu+ -> SimpleMenu s n+simpleMenu title regionNameBuilder items =+ menu title regionNameBuilder items id++defaultMenuPadding :: Int+defaultMenuPadding = 7++-- | Create a 'Menu'.+--+-- By default, menus use the 'LeftToRight' content orientation. This can+-- be changed with 'setMenuOrientation'.+--+-- By default, entries are rendered using 'txt'. Change this with+-- 'setDefaultEntryRenderer' or 'setEntryRenderer'.+--+-- By default, the menu title is rendered using 'txt'. Change this with+-- 'setTitleRenderer'.+menu :: T.Text+ -- ^ The menu's title+ -> (MenuRegion -> n)+ -- ^ The menu's resource name constructor+ -> [MenuItem s n k]+ -- ^ The items in this menu+ -> (k -> EventM n s ())+ -- ^ The event handler to invoke when entries are activated+ -> Menu s n k+menu title regionNameBuilder items handler =+ let defaultWidth = (maximum $ menuItemWidth <$> items) + defaultMenuPadding+ in Menu { menuTitle = title+ , menuTitleRenderer = const txt+ , menuItems = V.fromList items+ , menuIsOpen = False+ , menuContentWidth = defaultWidth+ , menuTitleName = regionNameBuilder MenuTitle+ , menuRegionNameBuilder = regionNameBuilder+ , menuSelectedIndex = Nothing+ , menuEventHandler = handler+ , menuFallbackEventHandler = const $ const $ return False+ , menuEntryDefaultRenderer = \_ _ label -> txt label+ , menuOrientation = LeftToRight+ }++-- | A trigger to be executed when an entry with this trigger+-- is activated. This is exposed for completeness only; use+-- 'menuEntryForKey', 'menuEntryForAction', and 'menuEntryForEvent' to+-- work with this data type indirectly.+data EntryTrigger s n k =+ TriggerEvent !(EventTrigger k)+ -- ^ The entry produces an 'EventTrigger' to be handled by a+ -- 'KeyDispatcher'+ | TriggerAction !(EventM n s ())+ -- ^ The entry runs a specific 'EventM' action++-- | A specialization of 'Menu' whose entries are associated with+-- specific keys or abstract key events handled by a 'KeyDispatcher'.+-- Create one of these with 'menuWithDispatcher'.+type DispatchingMenu s n k = Menu s n (EntryTrigger s n k)++-- | A specialization of 'MenuItem' for 'DispatchingMenu'. Create these+-- with 'menuGap', 'menuSeparator', 'submenu', 'menuEntryForKey',+-- 'menuEntryForAction', and 'menuEntryForEvent'.+type DispatchingMenuItem s n k = MenuItem s n (EntryTrigger s n k)++-- | Create a 'Menu' whose entries are activated by specific triggers,+-- including specified key bindings or abstract key events associated+-- with a 'KeyDispatcher'. This uses 'entryWithKeybinding' as its+-- default entry renderer to show available keybindings for entries+-- associated with key events.+--+-- To create entries in this menu, use 'menuEntryForKey',+-- 'menuEntryForEvent', and 'menuEntryForAction'.+menuWithDispatcher :: (Eq k)+ => KeyDispatcher k (EventM n s)+ -- ^ The key dispatcher to use to build the menu, and+ -- whose handlers should be invoked by the menu's+ -- entries when activated+ -> T.Text+ -- ^ The menu's title+ -> (MenuRegion -> n)+ -- ^ The menu's resource name constructor+ -> [DispatchingMenuItem s n k]+ -- ^ The items in this menu+ -> DispatchingMenu s n k+menuWithDispatcher kd title regionNameBuilder items =+ setWidth $+ addFallbackHandler $+ setDefaultEntryRenderer (entryWithKeybinding kd) $+ menu title regionNameBuilder items handler+ where+ setWidth m =+ m { menuContentWidth = menuContentWidth m + 4 }++ addFallbackHandler m =+ m { menuFallbackEventHandler = handleKey kd }++ handler trigger =+ case trigger of+ TriggerEvent (ByKey b) -> invokeHandler $ lookupVtyEvent (kbKey b) (F.toList $ kbMods b) kd+ TriggerEvent (ByEvent ev) -> invokeHandler $ lookupEvent ev kd+ TriggerAction act -> act+ where+ invokeHandler Nothing = return ()+ invokeHandler (Just kh) = handlerAction $ kehHandler $ khHandler kh++-- | An entry rendering function usable with 'setDefaultEntryRenderer'+-- and 'setEntryRenderer' that renders a menu entry with the first known+-- available keybinding for its abstract event, as configured in the+-- specified 'KeyDispatcher'.+entryWithKeybinding :: (Eq k)+ => KeyDispatcher k (EventM n s)+ -- ^ The key dispatcher to check for bindings+ -> MenuOrientation+ -- ^ The menu's orientation+ -> EntryTrigger s n k+ -- ^ The entry's trigger+ -> T.Text+ -- ^ The entry's label+ -> Widget n+entryWithKeybinding kd o e label =+ let maybeShowKeybinding w = fromMaybe w $ do+ keybinding <- case e of+ TriggerEvent (ByKey b) -> return b+ TriggerEvent (ByEvent ev) -> listToMaybe $ bindingsForEvent kd ev+ TriggerAction {} -> Nothing++ let renderedBinding = withDefAttr menuEntryKeybindingAttr $+ txt $ ppBinding keybinding+ return $ case o of+ LeftToRight ->+ w <+> renderedBinding+ RightToLeft ->+ renderedBinding <+> w++ in maybeShowKeybinding $ case o of+ LeftToRight -> padRight Max $ txt label+ RightToLeft -> padLeft Max $ txt label++-- | Create a menu entry that is activated by the specified key binding,+-- irrespective of the enclosing menu's 'KeyDispatcher' configuration.+-- This entry will show the specified keybinding in its text.+menuEntryForKey :: T.Text+ -- ^ The menu entry's label+ -> Binding+ -- ^ The specific key binding to trigger this menu entry+ -> DispatchingMenuItem s n k+menuEntryForKey label b = menuEntry label $ TriggerEvent $ ByKey b++-- | Create a menu entry that generates the specified abstract key event+-- when activated, thus triggering the enclosing menu's 'KeyDispatcher'+-- handler for that event. This entry will show the first known+-- keybinding for the specified abstract key event, if any.+menuEntryForEvent :: T.Text+ -- ^ The menu entry's label+ -> k+ -- ^ The abstract key event to generate when this+ -- entry is activated+ -> DispatchingMenuItem s n k+menuEntryForEvent label ev = menuEntry label $ TriggerEvent $ ByEvent ev++-- | Create a menu entry that invokes the specified 'EventM' action when+-- activated. Use this for entries that are not invoked by specific keys+-- or associated with abstract key events.+menuEntryForAction :: T.Text+ -- ^ The menu entry's label+ -> EventM n s ()+ -- ^ The action to evaluate when this entry is+ -- activated+ -> DispatchingMenuItem s n k+menuEntryForAction label act = menuEntry label $ TriggerAction act++-- | Close a menu and unselect any selected entry. Also closes any open+-- submenus in the menu, recursively.+closeMenu :: Menu s n k -> Menu s n k+closeMenu m =+ closeSubmenus $+ m & menuIsOpenL .~ False+ & menuSelectedIndexL .~ Nothing++closeSubmenus :: Menu s n k -> Menu s n k+closeSubmenus m =+ m & menuItemsL.each._Submenu %~ closeMenu++-- | Open a menu.+openMenu :: Menu s n k -> Menu s n k+openMenu m = m & menuIsOpenL .~ True++-- | Toggle the menu's open state.+toggleMenu :: Menu s n k -> Menu s n k+toggleMenu m =+ if m^.menuIsOpenL+ then closeMenu m+ else openMenu m++-- | Get the screen width of this menu item if it is an entry; zero+-- otherwise.+menuItemWidth :: MenuItem s n k -> Int+menuItemWidth MISeparator = 0+menuItemWidth MIGap = 0+menuItemWidth (MIEntry e) = menuEntryWidth e+menuItemWidth (MISubmenu sm) = textWidth $ menuTitle sm++-- | Get this entry's width, i.e., the width of its label.+menuEntryWidth :: MenuEntry s n k -> Int+menuEntryWidth = textWidth . menuEntryLabel++-- | Render a menu.+--+-- If the menu is closed, only its title is rendered. If the menu is+-- open, its title is rendered with its contents shown as a floating+-- layer vertically positioned below the title.+--+-- When menu contents are shown, they are rendered in a 'border', and+-- separators are rendered with 'hBorder'. Use 'withBorderStyle' to+-- change how such borders are drawn, e.g.,+--+-- @+-- drawUi :: s -> Widget n+-- drawUi s =+-- withBorderStyle unicodeRounded $+-- renderMenu s (s^.myMenu)+-- @+renderMenu :: (Ord n) => s -> Menu s n k -> Widget n+renderMenu s m =+ if menuIsOpen m+ then contentsLayer `above` title+ else title+ where+ contentsLayer = clampLayerToScreen $+ translateLayer layerOffset $ renderMenuContents s m+ layerOffset =+ case m^.menuOrientationL of+ LeftToRight -> Location (-1, 1)+ RightToLeft -> Location (-1 * (menuContentWidth m - textWidth (menuTitle m) + 1), 1)+ setTitleAttr = if menuIsOpen m+ then forceAttr menuTitleSelectedAttr+ else withDefAttr menuTitleAttr+ maybePutCursor =+ if menuIsOpen m+ then putCursor (menuTitleName m) (Location (0, 0))+ else id+ title = clickable (menuTitleName m) $+ maybePutCursor $+ setTitleAttr $+ menuTitleRenderer m s $+ menuTitle m++renderMenuContents :: (Ord n) => s -> Menu s n k -> Widget n+renderMenuContents s m = body+ where+ body = withDefAttr menuAttr $+ joinBorders $+ border $+ hLimit (menuContentWidth m) $+ clickable (menuRegionNameBuilder m MenuBody) $+ vBox $+ renderMenuItem <$> (zip [0..] $ V.toList $ menuItems m)++ renderMenuItem (_, MISeparator) = hBorder+ renderMenuItem (_, MIGap) = vLimit 1 $ fill ' '+ renderMenuItem (i, MIEntry e) = renderMenuEntry i e+ renderMenuItem (i, MISubmenu sm) = renderSubmenu i sm++ maybePutCursor i =+ if menuSelectedIndex m == Just i+ then putCursor (menuRegionNameBuilder m $ MenuItemAt i) (Location (0, 0))+ else id++ renderSubmenu i sm =+ let submenuTitle = vLimit 1 $+ maybePutCursor i $+ padRight (Pad 1) $+ padLeft (Pad 1) $+ addSubmenuPointer $+ padEntry $+ txt $ menuTitle sm+ addSubmenuPointer w =+ case m^.menuOrientationL of+ LeftToRight -> w <+> txt ">"+ RightToLeft -> txt "<" <+> w+ layerOffset =+ case menuOrientation sm of+ LeftToRight -> Location (menuContentWidth m + 1, -1)+ RightToLeft -> Location (-1 * (menuContentWidth sm + 3), -1)+ submenuLayer = clampLayerToScreen $+ translateLayer layerOffset $ renderMenuContents s sm+ maybeAddLayer = if sm^.menuIsOpenL+ then (submenuLayer `above`)+ else id+ maybeSetAttr = if Just i == menuSelectedIndex m+ then forceAttr menuEntrySelectedAttr+ else id+ in maybeAddLayer $+ maybeSetAttr submenuTitle++ padEntry = case m^.menuOrientationL of+ LeftToRight -> padRight Max+ RightToLeft -> padLeft Max++ renderMenuEntry i e =+ let renderEntry = fromMaybe (menuEntryDefaultRenderer m) (menuEntryRenderer e)+ in setEntryAttr i e $+ vLimit 1 $+ maybePutCursor i $+ padRight (Pad 1) $+ padLeft (Pad 1) $+ padEntry $+ renderEntry (menuOrientation m) (menuEntryEvent e) (menuEntryLabel e)++ setEntryAttr i e =+ if Just i == menuSelectedIndex m+ then if menuEntryEnabled e s+ then forceAttr menuEntrySelectedAttr+ else forceAttr menuEntrySelectedDisabledAttr+ else if menuEntryEnabled e s+ then id+ else forceAttr menuEntryDisabledAttr++-- | The base attribute of menus.+menuAttr :: AttrName+menuAttr = attrName "brick" <> attrName "menu"++-- | Menu titles.+menuTitleAttr :: AttrName+menuTitleAttr = menuAttr <> attrName "title"++-- | A highlighted key in a menu title as rendered with+-- 'titleHightlightKey', based on 'menuTitleAttr'.+menuTitleKeyHighlightAttr :: AttrName+menuTitleKeyHighlightAttr = menuTitleAttr <> attrName "highlightedKey"++-- | Selected menu titles, for open menus.+menuTitleSelectedAttr :: AttrName+menuTitleSelectedAttr = menuTitleAttr <> attrName "selected"++-- | The base attribute for menu bodies.+menuBodyAttr :: AttrName+menuBodyAttr = menuAttr <> attrName "body"++-- | Menu entry keybindings for entries in menus created with+-- 'menuWithDispatcher'.+menuEntryKeybindingAttr :: AttrName+menuEntryKeybindingAttr = menuBodyAttr <> attrName "keybinding"++-- | Disabled menu entries.+menuEntryDisabledAttr :: AttrName+menuEntryDisabledAttr = menuBodyAttr <> attrName "disabled"++-- | Selected and enabled menu entries.+menuEntrySelectedAttr :: AttrName+menuEntrySelectedAttr = menuBodyAttr <> attrName "selected"++-- | Selected and disnabled menu entries.+menuEntrySelectedDisabledAttr :: AttrName+menuEntrySelectedDisabledAttr = menuEntrySelectedAttr <> attrName "disabled"++-- | A title rendering function that highlights the specified character+-- with 'menuTitleKeyHighlightAttr' if it appears in the title,+-- case-insensitively. Use with 'setTitleRenderer'.+titleHightlightKey :: Char -> s -> T.Text -> Widget n+titleHightlightKey c _ title = hBox parts+ where+ parts = go "" title++ go acc (h T.:< tl)+ | toLower h == toLower c =+ (if T.null acc then [] else [txt acc]) <>+ [withDefAttr menuTitleKeyHighlightAttr $ char h] <>+ go "" tl+ | otherwise =+ go (T.snoc acc h) tl+ go acc T.Empty =+ if T.null acc then [] else [txt acc]++-- | Select the next entry in a menu, or the first one if no entry is+-- currently selected.+selectNextEntry :: Menu s n k -> Menu s n k+selectNextEntry m =+ case matching V.!? 0 of+ Nothing -> m+ Just (newIdx, _) -> m & menuSelectedIndexL .~ Just newIdx+ where+ dropAmt = case m^.menuSelectedIndexL of+ Nothing -> 0+ Just i -> i + 1+ is = m^.menuItemsL+ matching = V.filter (itemIsSelectable . snd) items+ pairs = V.zip (V.enumFromN 0 (V.length is)) is+ items = V.drop dropAmt $ pairs <> pairs++itemIsSelectable :: MenuItem s n k -> Bool+itemIsSelectable (MIEntry {}) = True+itemIsSelectable (MISubmenu {}) = True+itemIsSelectable _ = False++-- | Select the prevouis entry in a menu, or the last one if no entry is+-- currently selected.+selectPrevEntry :: Menu s n k -> Menu s n k+selectPrevEntry m =+ case matching V.!? 0 of+ Nothing -> m+ Just (newIdx, _) -> m & menuSelectedIndexL .~ Just newIdx+ where+ takeAmt = fromMaybe 0 $ m^.menuSelectedIndexL+ is = m^.menuItemsL+ matching = V.filter (itemIsSelectable . snd) items+ pairs = V.zip (V.enumFromN 0 (V.length is)) is+ items = V.reverse $ pairs <> V.take takeAmt pairs++withMenu :: Traversal' s (Menu s n k) -> (Menu s n k -> EventM n s Bool) -> EventM n s Bool+withMenu which f = do+ mMenu <- preuse which+ case mMenu of+ Nothing -> return False+ Just m -> f m++resolveMenuEventTarget :: Traversal' s (Menu s n k)+ -> EventM n s [Int]+resolveMenuEventTarget which = do+ mMenu <- preuse which+ case mMenu of+ Nothing -> return []+ Just m -> return $ resolveMenuEventTarget' m++resolveMenuEventTarget' :: Menu s n k -> [Int]+resolveMenuEventTarget' m = fromMaybe [] $ do+ idx <- m^.menuSelectedIndexL+ let is = m^.menuItemsL+ sel <- is V.!? idx++ case sel of+ MISubmenu sm -> do+ -- If the submenu is open, recurse; if it is not, don't add+ -- its index because we aren't targeting the submenu at that+ -- index.+ if not $ sm^.menuIsOpenL+ then return []+ else do+ let rest = maybe [] resolveMenuEventTarget' $+ m^?menuItemsL.ix idx._Submenu++ return $ idx : rest+ _ -> return []++targetMenu :: Traversal' s (Menu s n k)+ -> [Int]+ -> Traversal' s (Menu s n k)+targetMenu which path = which . go path+ where+ go [] = id+ go (idx:rest) = menuItemsL.ix idx._Submenu . go rest++-- | Handle an event for this menu and return @True@, or return @False@+-- if the event was not handled (e.g. because the event was not a menu+-- title mouse click or because the menu was not open to receive the+-- event).+--+-- Events handled include:+--+-- * Mouse clicks on the menu title will toggle whether the menu is+-- open.+-- * If a submenu entry is selected, arrow keys will open and close it+-- depending on the menu orientation.+-- * Mouse clicks on submenu entries will open their submenus.+-- * @Esc@ will close the menu if no submenus are open; otherwise it+-- will close the last open submenu.+-- * If no entry is selected, the Down arrow key will select the first+-- entry and the Up arrow key will select the last entry.+-- * If an entry is selected, the Down arrow key will select the next+-- entry and the Up arrow key will select the previous entry.+-- * If the selected entry is a submenu and the submenu is open, events+-- will be delegated to the submenu until it closes.+--+-- In all other cases, this will attempt to defer to the menu's selected+-- entry or submenu to handle the event. This returns @True@ if the+-- event was one of the above and was handled, @True@ if the event was+-- not one of the above but was handled by the menu's selected entry, or+-- @False@ otherwise.+--+-- A return value of @True@ indicates that the event should not be+-- handled by the application because it was destined for the menu; a+-- return value of @False@ indicates that the event should be handled by+-- the application because it did not affect the menu or its entries in+-- their current state for any reason. Consequently, a common pattern+-- when using this function will look something like this:+--+-- @+-- myApplicationEventHandler :: BrickEvent n e -> EventM n s ()+-- myApplicationEventHandler e = do+-- handled <- handleMenuEvent myMenuLens e+-- when (not handled) $ do+-- -- Go on to handle the event in the rest of the application+-- @+handleMenuEvent :: (Eq n)+ => Traversal' s (Menu s n k)+ -- ^ The traversal into the application state where the+ -- menu state can be found+ -> BrickEvent n e+ -- ^ The event to handle+ -> EventM n s Bool+handleMenuEvent which e = do+ -- First, determine where we're routing the event based on whether+ -- the current selection targets an open submenu.+ path <- resolveMenuEventTarget which++ handled <- handleMenuEventCommon which path e+ if handled+ then return True+ else handleMenuEventFallback which path e++handleMenuEventFallback :: (Eq n) => Traversal' s (Menu s n k) -> [Int] -> BrickEvent n e -> EventM n s Bool+handleMenuEventFallback which path (VtyEvent (Vty.EvKey k mods)) =+ withMenu (targetMenu which path) $ \m -> do+ handled <- menuFallbackEventHandler m k mods+ return handled+handleMenuEventFallback _ _ _ =+ return False++handleMenuEventCommon :: (Eq n) => Traversal' s (Menu s n k) -> [Int] -> BrickEvent n e -> EventM n s Bool+handleMenuEventCommon which path (VtyEvent (Vty.EvKey Vty.KEnter [])) = do+ withMenu (targetMenu which path) $ \m -> do+ let sel = m^.menuSelectedIndexL+ case sel of+ Nothing -> return True+ Just idx -> activateMenuItem which path idx+handleMenuEventCommon which path (VtyEvent (Vty.EvKey Vty.KRight [])) = do+ withMenu which $ \m ->+ case menuOrientation m of+ LeftToRight ->+ maybeOpenSubmenu which path+ RightToLeft ->+ maybeCloseSubmenu which path+handleMenuEventCommon which path (VtyEvent (Vty.EvKey Vty.KLeft [])) = do+ withMenu which $ \m ->+ case menuOrientation m of+ LeftToRight ->+ maybeCloseSubmenu which path+ RightToLeft ->+ maybeOpenSubmenu which path+handleMenuEventCommon which path (VtyEvent (Vty.EvKey Vty.KDown [])) = do+ targetMenu which path %= selectNextEntry+ return True+handleMenuEventCommon which path (VtyEvent (Vty.EvKey Vty.KUp [])) = do+ targetMenu which path %= selectPrevEntry+ return True+handleMenuEventCommon which path (MouseDown n _ _ (Location (_, row))) = do+ withMenu (targetMenu which path) $ \m -> do+ let mkRegionName = m^.menuRegionNameBuilderL++ if | mkRegionName MenuTitle == n -> do+ (targetMenu which path).menuIsOpenL %= not+ return True+ | mkRegionName MenuBody == n ->+ -- Map the location to the clicked menu entry; since each+ -- item is expected to be exactly one row high, the row+ -- index here is equivalent to the item index.+ activateMenuItem which path row+ | otherwise -> return False+handleMenuEventCommon which path (VtyEvent (Vty.EvMouseDown {})) = do+ targetMenu which path %= closeMenu+ return True+handleMenuEventCommon which path (VtyEvent (Vty.EvKey Vty.KEsc [])) = do+ withMenu (targetMenu which path) $ \m -> do+ if menuIsOpen m+ then do+ targetMenu which path %= closeMenu+ return True+ else return False+handleMenuEventCommon _ _ _ =+ return False++maybeCloseSubmenu :: Traversal' s (Menu s n k) -> [Int] -> EventM n s Bool+maybeCloseSubmenu which path = do+ -- Close the current menu if it is a submenu.+ case path of+ [] -> return False+ _ -> do+ targetMenu which path %= closeMenu+ return True++maybeOpenSubmenu :: Traversal' s (Menu s n k) -> [Int] -> EventM n s Bool+maybeOpenSubmenu which path = do+ withMenu (targetMenu which path) $ \m -> do+ let sel = m^.menuSelectedIndexL+ case sel of+ Nothing -> return False+ Just idx -> do+ -- If the selected item is a submenu that is not open,+ -- open it and select its first item.+ let is = m^.menuItemsL+ case is V.!? idx of+ Just (MISubmenu sm) | not (sm^.menuIsOpenL) -> do+ (targetMenu which path).menuItemsL.ix idx._Submenu %= (selectNextEntry . openMenu)+ return True+ _ -> return False++_Submenu :: Traversal' (MenuItem s n k) (Menu s n k)+_Submenu f (MISubmenu sm) = MISubmenu <$> f sm+_Submenu _ i = pure i++-- | Activate the menu's selected entry. If the selected entry is a+-- normal entry and is enabled, trigger its handler and close the menu+-- and its ancestors. If the selected entry is a submenu, open the+-- submenu.+activateMenuItem :: Traversal' s (Menu s n k) -> [Int] -> Int -> EventM n s Bool+activateMenuItem which path idx =+ withMenu (targetMenu which path) $ \m -> do+ s <- use id+ let handler = m^.menuEventHandlerL+ is = m^.menuItemsL+ case is V.!? idx of+ Just (MIEntry entry) -> do+ when (menuEntryEnabled entry s) $ do+ which %= closeMenu+ handler $ menuEntryEvent entry+ return True+ Just (MISubmenu {}) -> do+ -- If the submenu entry isn't the selected one, select+ -- it.+ when (Just idx /= (m^.menuSelectedIndexL)) $+ (targetMenu which path).menuSelectedIndexL .= Just idx++ (targetMenu which path).menuItemsL.ix idx._Submenu %= openMenu+ return True+ _ -> return False
+ src/Brick/Widgets/MenuBar.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+-- | This module provides a menu bar for grouping menus together.+--+-- Menu bars carry menus of a particular type using the menu types+-- provided in the @Brick.Widgets.Menu@ module. The type aliases+-- provided here correspond to the aliases for menu use cases:+--+-- * 'SimpleMenuBar': a menu bar made up of 'SimpleMenu's created with+-- 'simpleMenu'+-- * 'DispatchingMenuBar': a menu bar made up of 'DispatchingMenu's+-- created with 'menuWithDispatcher'+-- * 'MenuBar': the fully general type for menu bars with menus created+-- with 'menu'+--+-- In all cases, use 'newMenuBar' to construct a menu bar, and create+-- its menus using the corresponding menu constructor for the type of+-- menu bar you want to use.+--+-- Render the menu bar with 'renderMenuBar' and handle menu bar events+-- with 'handleMenuBarEvent', deferring to the application's event+-- handling for events that the menu bar doesn't handle.+--+-- Similar to individual menus, menu bars have an orientation that can+-- be changed with 'setMenuBarOrientation'.+--+-- This API requires the use of lenses for application state fields that+-- store menu bar state.+--+-- See the @MenuBarDemo@ demonstration program for a complete working+-- example of using this API.+--+-- = Adding a Menu Bar to An Application+--+-- To use this module in an application:+--+-- * Choose a menu bar type that you want to work with such as+-- 'SimpleMenuBar'.+-- * Add an application state field and lens for a value of the menu+-- bar's type, and add a constructor to the application's resource+-- name type, with an argument of type 'MenuRegion', for each menu+-- in the menu bar. Add lenses to the application state type with+-- 'Lens.Micro.TH.makeLenses'.+-- * Populate the application's initial state with the menu bar.+-- * Render the menu bar with 'renderMenuBar'.+-- * Handle incoming events first with 'handleMenuBarEvent', and when+-- 'handleMenuBarEvent' returns @False@, pass unhandled events on to+-- the existing application event handler.+module Brick.Widgets.MenuBar+ (+ -- * Types+ MenuBar+ , SimpleMenuBar+ , DispatchingMenuBar++ -- * Creating menu bars+ , newMenuBar++ -- * Handling events+ , handleMenuBarEvent++ -- * Rendering+ , renderMenuBar++ -- * Working with menu bars+ , hasOpenMenu+ , closeAllMenus+ , openMenuAtIndex+ , toggleMenuAtIndex+ , setMenuBarOrientation+ )+where++import Control.Monad (when)+import Data.Maybe (isJust, listToMaybe, fromMaybe)+import Lens.Micro.Platform ((^.), (&), (%~), (.~), Lens', ix, each)+import Lens.Micro.Mtl++import qualified Data.Foldable as F+import qualified Data.Vector as V++import qualified Graphics.Vty as Vty++import Brick.Types+import Brick.Widgets.Core+import Brick.Widgets.Menu++-- | A menu bar holding a sequence of menus.+--+-- A menu bar can have up to one open menu at a time.+data MenuBar s n k =+ MenuBar { menuBarOrientation :: !MenuOrientation+ , menuBarMenus :: !(V.Vector (Menu s n k))+ }++suffixLenses ''MenuBar++-- | A specialization of 'MenuBar' for menus with 'EventM' handlers; use+-- this with 'simpleMenu'.+type SimpleMenuBar s n = MenuBar s n (EventM n s ())++-- | A specialization of 'MenuBar' for menus with abstract key event+-- triggers; this with 'menuWithDispatcher'.+type DispatchingMenuBar s n k = MenuBar s n (EventM n s (EntryTrigger s n k))++-- | Create a new menu bar from the specified menu list. If the list is+-- empty, this calls 'error'.+newMenuBar :: [Menu s n k] -> MenuBar s n k+newMenuBar [] = error "BUG: newMenuBar requires a non-empty list"+newMenuBar ms = MenuBar LeftToRight $ V.fromList ms++-- | Return whether this menu bar has an open menu.+hasOpenMenu :: MenuBar s n k -> Bool+hasOpenMenu = isJust . getOpenMenu++-- | Get this menu bar's current open menu and its index, if any.+getOpenMenu :: MenuBar s n k -> Maybe (Int, Menu s n k)+getOpenMenu mb = do+ let ms = menuBarMenus mb+ idx <- V.findIndex menuIsOpen ms+ return (idx, ms V.! idx)++-- | Render this menu bar with the given application state as input.+renderMenuBar :: (Ord n) => s -> MenuBar s n k -> Widget n+renderMenuBar s mb =+ withDefAttr menuTitleAttr $ padForOrientation body+ where+ padForOrientation = case mb^.menuBarOrientationL of+ LeftToRight -> padRight Max+ RightToLeft -> padLeft Max . padRight (Pad 1)++ body = hBox $+ padLeft (Pad 1) <$>+ F.toList (renderMenu s <$> menuBarMenus mb)++-- | Given a resource name, find the menu whose title bar portion+-- matches the resource name, if any.+getMenuTitleMatch :: (Eq n) => MenuBar s n k -> n -> Maybe (Int, Menu s n k)+getMenuTitleMatch mb n =+ listToMaybe $ filter matchesTitle $ zip [0..] (F.toList $ mb^.menuBarMenusL)+ where+ matchesTitle (_, m) = n == menuTitleName m++-- | Handle an event for this menu bar and return @True@, or return+-- @False@ if the event was not handled (e.g. because the event was not+-- a menu title mouse click or because no menu was open to receive the+-- event).+--+-- Events handled include:+--+-- * Mouse clicks on menu titles will open the clicked menu, closing+-- other open menus.+-- * Left and Right arrow keys will cycle between menus if there is an+-- open menu.+-- * If a submenu entry is selected, the arrow keys will open it or+-- close it if it is open, depending on the configured menu bar+-- orientation.+-- * @Esc@ will close the currently-open menu.+--+-- In all other cases, this will attempt to defer to the opened menu to+-- handle the event. This returns @True@ if the event was one of the+-- above and was handled, @True@ if the event was not one of the above+-- but was handled by the open menu, or @False@ otherwise.+--+-- A return value of @True@ indicates that the event should not be+-- handled by the application because it was destined for the menu bar+-- or one of its menus; a return value of @False@ indicates that the+-- event should be handled by the application because it did not affect+-- the menu bar or its menus in their current state for any reason.+-- Consequently, a common pattern when using this function will look+-- something like this:+--+-- @+-- myApplicationEventHandler :: BrickEvent n e -> EventM n s ()+-- myApplicationEventHandler e = do+-- handled <- handleMenuBarEvent myMenuBarLens e+-- when (not handled) $ do+-- -- Go on to handle the event in the rest of the application+-- @+handleMenuBarEvent :: (Eq n)+ => Lens' s (MenuBar s n k)+ -- ^ The lens into the application state where the+ -- menu state can be found+ -> BrickEvent n e+ -- ^ The event to handle+ -> EventM n s Bool+handleMenuBarEvent which e@(VtyEvent (Vty.EvKey Vty.KLeft [])) = do+ -- Since this key might be handled by the open menu, try that first+ -- and only switch menus if it wasn't handled by the menu.+ handled <- withOpenMenu which $ \(idx, _) ->+ handleMenuEvent (which.menuBarMenusL.ix idx) e++ when (not handled) $+ which %= openPreviousMenu++ return True+handleMenuBarEvent which e@(VtyEvent (Vty.EvKey Vty.KRight [])) = do+ -- Since this key might be handled by the open menu, try that first+ -- and only switch menus if it wasn't handled by the menu.+ handled <- withOpenMenu which $ \(idx, _) ->+ handleMenuEvent (which.menuBarMenusL.ix idx) e++ when (not handled) $+ which %= openNextMenu++ return True+handleMenuBarEvent which e@(MouseDown n _ _ _) = do+ mb <- use which+ case getMenuTitleMatch mb n of+ Nothing -> withOpenMenu which $ \(idx, _) ->+ handleMenuEvent (which.menuBarMenusL.ix idx) e+ Just (i, _) -> do+ mMatchingMenu <- preuse (which.menuBarMenusL.ix i)+ case mMatchingMenu of+ Nothing -> return ()+ Just matchingMenu ->+ when (not $ menuIsOpen matchingMenu) $ do+ which %= closeAllMenus+ which %= openMenuAtIndex i+ return True+handleMenuBarEvent which e =+ withOpenMenu which $ \(idx, _) ->+ handleMenuEvent (which.menuBarMenusL.ix idx) e++-- | Given a menu bar with an open menu, switch the open menu to the one+-- preceding the currently open one, or do nothing if no menu is open.+openPreviousMenu :: MenuBar s n k -> MenuBar s n k+openPreviousMenu mb = fromMaybe mb $ do+ (i, _) <- getOpenMenu mb+ let newIndex = if i == 0+ then V.length (mb^.menuBarMenusL) - 1+ else i - 1+ return $ openMenuAtIndex newIndex $ closeAllMenus mb++-- | Given a menu bar with an open menu, switch the open menu to the one+-- following the currently open one, or do nothing if no menu is open.+openNextMenu :: MenuBar s n k -> MenuBar s n k+openNextMenu mb = fromMaybe mb $ do+ (i, _) <- getOpenMenu mb+ let newIndex = if i == V.length (mb^.menuBarMenusL) - 1+ then 0+ else i + 1+ return $ openMenuAtIndex newIndex mb++-- | Close all open menus in this menu bar.+closeAllMenus :: MenuBar s n k -> MenuBar s n k+closeAllMenus mb = mb & menuBarMenusL.each %~ closeMenu++-- | Open the menu at the specified index, closing any other open menus+-- in the menu bar. If the index is invalid, this does nothing.+openMenuAtIndex :: Int -> MenuBar s n k -> MenuBar s n k+openMenuAtIndex i mb = (closeAllMenus mb) & menuBarMenusL.ix i %~ openMenu++-- | Set the menu orientation of the menu bar and all of its menus. For+-- details, see 'setMenuOrientation'.+setMenuBarOrientation :: MenuOrientation -> MenuBar s n k -> MenuBar s n k+setMenuBarOrientation o mb = mb & menuBarOrientationL .~ o+ & menuBarMenusL.each %~ setMenuOrientation o++-- | Toggle the open state of the menu at the specified index. If+-- toggling to open, this will close any other open menus in the menu+-- bar. If the index is invalid, this does nothing.+toggleMenuAtIndex :: Int -> MenuBar s n k -> MenuBar s n k+toggleMenuAtIndex i mb =+ case getOpenMenu mb of+ Nothing -> openMenuAtIndex i mb+ Just (idx, _) -> if idx == i+ then closeAllMenus mb+ else openMenuAtIndex i mb++-- | Given a lens to access a menu bar and a handler to invoke on its+-- currently open menu, invoke the handler if there is an open menu and+-- return its result, or do nothing and return False otherwise.+withOpenMenu :: Lens' s (MenuBar s n k) -> ((Int, Menu s n k) -> EventM n s Bool) -> EventM n s Bool+withOpenMenu which f = do+ mb <- use which+ case getOpenMenu mb of+ Nothing -> return False+ Just pair -> f pair
src/Brick/Widgets/ProgressBar.hs view
@@ -3,6 +3,7 @@ -- | This module provides a progress bar widget. module Brick.Widgets.ProgressBar ( progressBar+ , customProgressBar -- * Attributes , progressCompleteAttr , progressIncompleteAttr@@ -37,17 +38,42 @@ -> Float -- ^ The progress value. Should be between 0 and 1 inclusive. -> Widget n-progressBar mLabel progress =+progressBar = customProgressBar ' ' ' '++-- | Draw a progress bar with the specified (optional) label,+-- progress value and custom characters to fill the progress.+-- This fills available horizontal space and is one row high.+-- Please be aware of using wide characters in Brick,+-- see [Wide Character Support and the TextWidth class](https://github.com/jtdaugherty/brick/blob/main/docs/guide.rst#wide-character-support-and-the-textwidth-class)+customProgressBar :: Char+ -- ^ Character to fill the completed part.+ -> Char+ -- ^ Character to fill the incomplete part.+ -> Maybe String+ -- ^ The label. If specified, this is shown in the center of+ -- the progress bar.+ -> Float+ -- ^ The progress value. Should be between 0 and 1 inclusive.+ -> Widget n+customProgressBar completeChar incompleteChar mLabel progress = Widget Greedy Fixed $ do c <- getContext let barWidth = c^.availWidthL label = fromMaybe "" mLabel labelWidth = safeWcswidth label spacesWidth = barWidth - labelWidth- leftPart = replicate (spacesWidth `div` 2) ' '- rightPart = replicate (barWidth - (labelWidth + length leftPart)) ' '+ leftWidth = spacesWidth `div` 2+ rightWidth = barWidth - labelWidth - leftWidth+ completeWidth = round $ progress * toEnum barWidth++ leftCompleteWidth = min leftWidth completeWidth+ leftIncompleteWidth = leftWidth - leftCompleteWidth+ leftPart = replicate leftCompleteWidth completeChar ++ replicate leftIncompleteWidth incompleteChar+ rightCompleteWidth = max 0 (completeWidth - labelWidth - leftWidth)+ rightIncompleteWidth = rightWidth - rightCompleteWidth+ rightPart = replicate rightCompleteWidth completeChar ++ replicate rightIncompleteWidth incompleteChar+ fullBar = leftPart <> label <> rightPart- completeWidth = round $ progress * toEnum (length fullBar) adjustedCompleteWidth = if completeWidth == length fullBar && progress < 1.0 then completeWidth - 1 else if completeWidth == 0 && progress > 0.0
src/Brick/Widgets/Table.hs view
@@ -31,6 +31,13 @@ -- * Rendering , renderTable++ -- * Low-level API+ , RenderedTableCells(..)+ , BorderConfiguration(..)+ , tableCellLayout+ , addBorders+ , alignColumns ) where @@ -90,11 +97,16 @@ , tableRows :: [[Widget n]] , defaultColumnAlignment :: ColumnAlignment , defaultRowAlignment :: RowAlignment- , drawSurroundingBorder :: Bool- , drawRowBorders :: Bool- , drawColumnBorders :: Bool+ , tableBorderConfiguration :: BorderConfiguration } +-- | A border configuration for a table.+data BorderConfiguration =+ BorderConfiguration { drawSurroundingBorder :: Bool+ , drawRowBorders :: Bool+ , drawColumnBorders :: Bool+ }+ -- | Construct a new table. -- -- The argument is the list of rows with the topmost row first, with@@ -148,27 +160,29 @@ t = Table { columnAlignments = mempty , rowAlignments = mempty , tableRows = rows- , drawSurroundingBorder = True- , drawRowBorders = True- , drawColumnBorders = True , defaultColumnAlignment = AlignLeft , defaultRowAlignment = AlignTop+ , tableBorderConfiguration =+ BorderConfiguration { drawSurroundingBorder = True+ , drawRowBorders = True+ , drawColumnBorders = True+ } } -- | Configure whether the table draws a border on its exterior. surroundingBorder :: Bool -> Table n -> Table n surroundingBorder b t =- t { drawSurroundingBorder = b }+ t { tableBorderConfiguration = (tableBorderConfiguration t) { drawSurroundingBorder = b } } -- | Configure whether the table draws borders between its rows. rowBorders :: Bool -> Table n -> Table n rowBorders b t =- t { drawRowBorders = b }+ t { tableBorderConfiguration = (tableBorderConfiguration t) { drawRowBorders = b } } -- | Configure whether the table draws borders between its columns. columnBorders :: Bool -> Table n -> Table n columnBorders b t =- t { drawColumnBorders = b }+ t { tableBorderConfiguration = (tableBorderConfiguration t) { drawColumnBorders = b } } -- | Align the specified column to the right. The argument is the column -- index, starting with zero. Silently does nothing if the index is out@@ -235,60 +249,104 @@ renderTable t = joinBorders $ Widget Fixed Fixed $ do- ctx <- getContext- cellResults <- forM (tableRows t) $ mapM render+ tableCellLayout t >>= addBorders >>= render - let maybeIntersperse f v = if f t then intersperse v else id- rowHeights = rowHeight <$> cellResults- colWidths = colWidth <$> byColumn- allRowAligns = (\i -> M.findWithDefault (defaultRowAlignment t) i (rowAlignments t)) <$>- [0..length rowHeights - 1]- allColAligns = (\i -> M.findWithDefault (defaultColumnAlignment t) i (columnAlignments t)) <$>- [0..length byColumn - 1]- rowHeight = maximum . fmap (imageHeight . image)- colWidth = maximum . fmap (imageWidth . image)- byColumn = transpose cellResults- toW = Widget Fixed Fixed . return- fillEmptyCell w h result =- if imageWidth (image result) == 0 && imageHeight (image result) == 0- then result { image = charFill (ctx^.attrL) ' ' w h }- else result- mkColumn (hAlign, width, colCells) =- let paddedCells = flip map (zip3 allRowAligns rowHeights colCells) $ \(vAlign, rHeight, cell) ->- applyColAlignment width hAlign $- applyRowAlignment rHeight vAlign $- toW $- fillEmptyCell width rHeight cell- maybeRowBorders = maybeIntersperse drawRowBorders (hLimit width hBorder)- in vBox $ maybeRowBorders paddedCells+-- | The result of performing table cell intermediate rendering and+-- layout.+data RenderedTableCells n =+ RenderedTableCells { renderedTableRows :: [[Widget n]]+ -- ^ The table's cells in row-major order.+ , renderedTableColumnWidths :: [Int]+ -- ^ The widths of the table's columns.+ , renderedTableRowHeights :: [Int]+ -- ^ The heights of the table's rows.+ , borderConfiguration :: BorderConfiguration+ -- ^ The border configuration to use.+ } - vBorders = mkVBorder <$> rowHeights- hBorders = mkHBorder <$> colWidths- mkHBorder w = hLimit w hBorder- mkVBorder h = vLimit h vBorder- topBorder =- hBox $ maybeIntersperse drawColumnBorders topT hBorders- bottomBorder =- hBox $ maybeIntersperse drawColumnBorders bottomT hBorders- leftBorder =- vBox $ topLeftCorner : maybeIntersperse drawRowBorders leftT vBorders <> [bottomLeftCorner]- rightBorder =- vBox $ topRightCorner : maybeIntersperse drawRowBorders rightT vBorders <> [bottomRightCorner]+-- | Augment rendered table cells with borders according to the+-- border configuration accompanying the cells.+addBorders :: RenderedTableCells n -> RenderM n (Widget n)+addBorders r = do+ let cfg = borderConfiguration r+ rows = renderedTableRows r+ rowHeights = renderedTableRowHeights r+ colWidths = renderedTableColumnWidths r - maybeWrap check f =- if check t then f else id- addSurroundingBorder body =- leftBorder <+> (topBorder <=> body <=> bottomBorder) <+> rightBorder- addColumnBorders =- let maybeAddCrosses = maybeIntersperse drawRowBorders cross- columnBorder = vBox $ maybeAddCrosses vBorders- in intersperse columnBorder+ contentWidth = sum colWidths+ contentHeight = sum rowHeights - let columns = mkColumn <$> zip3 allColAligns colWidths byColumn- body = hBox $- maybeWrap drawColumnBorders addColumnBorders columns- render $ maybeWrap drawSurroundingBorder addSurroundingBorder body+ hBorderLength = contentWidth + if drawColumnBorders cfg+ then max (length colWidths - 1) 0+ else 0+ vBorderHeight = contentHeight + if drawRowBorders cfg+ then max (length rowHeights - 1) 0+ else 0+ horizBorder = hLimit hBorderLength hBorder+ vertBorder = vLimit vBorderHeight vBorder + leftBorder =+ vBox [topLeftCorner, vertBorder, bottomLeftCorner]+ rightBorder =+ vBox [topRightCorner, vertBorder, bottomRightCorner]++ maybeWrap check f =+ if check cfg then f else id+ addSurroundingBorder b =+ leftBorder <+> (horizBorder <=> b <=> horizBorder) <+> rightBorder+ addRowBorders =+ intersperse horizBorder++ rowsWithColumnBorders = (\(h, row) -> hBox $ maybeColumnBorders h row) <$> zip rowHeights rows+ maybeColumnBorders height = maybeIntersperse cfg drawColumnBorders (vLimit height vBorder)+ body = vBox $+ maybeWrap drawRowBorders addRowBorders rowsWithColumnBorders++ return $ maybeWrap drawSurroundingBorder addSurroundingBorder body++tableCellLayout :: Table n -> RenderM n (RenderedTableCells n)+tableCellLayout t = do+ ctx <- getContext+ cellResults <- forM (tableRows t) $ mapM render++ let rowHeights = rowHeight <$> cellResults+ colWidths = colWidth <$> transpose cellResults+ numRows = length rowHeights+ numCols = if length cellResults >= 1+ then length (cellResults !! 0)+ else 0+ allRowAligns = (\i -> M.findWithDefault (defaultRowAlignment t) i (rowAlignments t)) <$>+ [0..numRows - 1]+ allColAligns = (\i -> M.findWithDefault (defaultColumnAlignment t) i (columnAlignments t)) <$>+ [0..numCols - 1]+ rowHeight = maximum . fmap (imageHeight . image)+ colWidth = maximum . fmap (imageWidth . image)++ toW = Widget Fixed Fixed . return+ fillEmptyCell w h result =+ if imageWidth (image result) == 0 && imageHeight (image result) == 0+ then result { image = charFill (ctx^.attrL) ' ' w h }+ else result+ mkRow (vAlign, height, rowCells) =+ let paddedCells = flip map (zip3 allColAligns colWidths rowCells) $ \(hAlign, width, cell) ->+ applyColAlignment width hAlign $+ applyRowAlignment height vAlign $+ toW $+ fillEmptyCell width height cell+ in paddedCells++ let rows = mkRow <$> zip3 allRowAligns rowHeights cellResults++ return $ RenderedTableCells { renderedTableRows = rows+ , renderedTableColumnWidths = colWidths+ , renderedTableRowHeights = rowHeights+ , borderConfiguration = tableBorderConfiguration t+ }++maybeIntersperse :: BorderConfiguration -> (BorderConfiguration -> Bool) -> Widget n -> [Widget n] -> [Widget n]+maybeIntersperse cfg f v | f cfg = intersperse v+ | otherwise = id+ topLeftCorner :: Widget n topLeftCorner = joinableBorder $ Edges False True False True @@ -301,20 +359,20 @@ bottomRightCorner :: Widget n bottomRightCorner = joinableBorder $ Edges True False True False -cross :: Widget n-cross = joinableBorder $ Edges True True True True--leftT :: Widget n-leftT = joinableBorder $ Edges True True False True--rightT :: Widget n-rightT = joinableBorder $ Edges True True True False--topT :: Widget n-topT = joinableBorder $ Edges False True True True--bottomT :: Widget n-bottomT = joinableBorder $ Edges True False True True+-- | Given a "table row" of widgets, align each one according to the+-- list of specified column alignments in columns of the specified+-- widths.+alignColumns :: [ColumnAlignment]+ -- ^ The column alignments to use for each widget,+ -- respectively.+ -> [Int]+ -- ^ The width of each column in terminal columns,+ -- respectively.+ -> [Widget n]+ -- ^ The column cells to align.+ -> [Widget n]+alignColumns as widths cells =+ (\(w, a, c) -> applyColAlignment w a c) <$> zip3 widths as cells applyColAlignment :: Int -> ColumnAlignment -> Widget n -> Widget n applyColAlignment width align w =
src/Data/IMap.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE CPP #-} module Data.IMap ( IMap , Run(..)@@ -21,7 +22,9 @@ , unsafeToAscList ) where +#if !MIN_VERSION_base(4,20,0) import Data.List (foldl')+#endif import Data.Monoid import Data.IntMap.Strict (IntMap) import GHC.Generics
tests/List.hs view
@@ -220,6 +220,20 @@ len = length l'' in maybe (len == 0) (== 0) (l'' ^. listSelectedL) +-- listMoveUp from beginning is the same as listMoveToEnd+prop_moveBeforeFirst :: Eq a => List n a -> Bool+prop_moveBeforeFirst l =+ let l' = setScrollWrap True l+ in listMoveUp (listMoveToBeginning l') =.= listMoveToEnd l'+ where (=.=) = (==) `on` (^. listSelectedL)++-- listMoveDown from end is the same as listMoveToBeginning+prop_moveAfterLast :: Eq a => List n a -> Bool+prop_moveAfterLast l =+ let l' = setScrollWrap True l+ in listMoveDown (listMoveToEnd l') =.= listMoveToBeginning l'+ where (=.=) = (==) `on` (^. 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 =@@ -347,6 +361,15 @@ l'' = listFindBy even l' in l' ^. listSelectedL == Just 1 && l'' ^. listSelectedL == Just 3++prop_listFindFirst :: Bool+prop_listFindFirst =+ let v = L [1..5] :: L Int+ l = list () v 1+ result1 = listFindFirst even l+ result2 = listFindFirst (> 10) l+ in result1 == Just (1, 2) &&+ result2 == Nothing prop_listSelectedElement_lazy :: Bool prop_listSelectedElement_lazy =
tests/Main.hs view
@@ -1,9 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -import Control.Applicative import Data.Bool (bool)-import Data.Traversable (sequenceA) import System.Exit (exitFailure, exitSuccess) import Data.IMap (IMap, Run(Run))@@ -14,6 +14,10 @@ import qualified List import qualified Render++#if !(MIN_VERSION_base(4,18,0))+import Control.Applicative (liftA2)+#endif instance Arbitrary v => Arbitrary (Run v) where arbitrary = liftA2 (\(Positive n) -> Run n) arbitrary arbitrary
tests/Render.hs view
@@ -10,6 +10,7 @@ import Data.Monoid #endif import qualified Graphics.Vty as V+import qualified Graphics.Vty.CrossPlatform.Testing as V import Brick.Widgets.Border (hBorder) import Control.Exception (SomeException, try) @@ -18,7 +19,7 @@ renderDisplay :: Ord n => [Widget n] -> IO () renderDisplay ws = do- outp <- V.outputForConfig V.defaultConfig+ outp <- V.mkDefaultOutput ctx <- V.displayContext outp region V.outputPicture ctx (renderWidget Nothing ws region) V.releaseDisplay outp