brick 1.6 → 3.0
raw patch · 74 files changed
Files
- CHANGELOG.md +392/−1
- LICENSE +1/−1
- README.md +81/−55
- brick.cabal +110/−99
- docs/guide.rst +34/−13
- 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 +16/−13
- programs/CustomEventDemo.hs +3/−4
- 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/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 +72/−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/Center.hs +19/−28
- src/Brick/Widgets/Core.hs +470/−220
- src/Brick/Widgets/Edit.hs +4/−4
- src/Brick/Widgets/FileBrowser.hs +74/−36
- src/Brick/Widgets/Internal.hs +125/−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/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,397 @@ 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 --- @@ -1619,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
@@ -13,7 +13,9 @@ 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 -------@@ -48,64 +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 |-| [`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 |-| [`hic-hac-hoe`](https://github.com/blastwind/hic-hac-hoe) | Play tic tac toe in terminal! |-| [`babel-cards`](https://github.com/srhoulam/babel-cards) | A TUI spaced-repetition memorization tool. Similar to Anki. |-| [`codenames-haskell`](https://github.com/VigneshN1997/codenames-haskell) | An implementation of the Codenames game |-| [`haradict`](https://github.com/srhoulam/haradict) | A TUI Arabic dictionary powered by [ElixirFM](https://github.com/otakar-smrz/elixir-fm) |--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 |-| [`brick-panes`](https://github.com/kquick/brick-panes) [[Hackage]](https://hackage.haskell.org/package/brick-panes) | A Brick overlay library providing composition and isolation of screen areas for TUI apps. |--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 ---------------@@ -118,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 ----------------@@ -140,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@@ -176,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 ... @@ -196,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.@@ -203,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.6+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,7 @@ main-is: AttrDemo.hs build-depends: base, brick,- vty,- text,- microlens+ vty executable brick-tabular-list-demo if !flag(demos)@@ -425,11 +393,9 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-mtl, microlens-th,- mtl, vector executable brick-list-demo@@ -442,7 +408,6 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-mtl, mtl,@@ -458,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@@ -474,7 +452,6 @@ build-depends: base, brick, vty,- text, microlens >= 0.3.0.0, microlens-th, microlens-mtl@@ -487,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)@@ -500,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)@@ -515,9 +486,6 @@ build-depends: base, brick, vty,- text,- vector,- mtl, microlens >= 0.3.0.0, microlens-th, microlens-mtl@@ -532,9 +500,6 @@ build-depends: base, brick, vty,- text,- vector,- mtl, microlens >= 0.3.0.0, microlens-th, microlens-mtl@@ -550,8 +515,7 @@ build-depends: base, brick, vty,- text,- microlens+ text executable brick-dynamic-border-demo if !flag(demos)@@ -562,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@@ -596,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 ----------------------------------- @@ -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,13 +66,14 @@ 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)@@ -80,7 +82,7 @@ colorDemo :: Widget () colorDemo =- updateAttrMap (A.applyAttrMappings borderMappings) $+ updateAttrMap (A.applyAttrMappings attrs) $ B.borderWithLabel (withAttr titleAttr $ str "title") $ hLimit 20 $ vLimit 5 $@@ -89,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/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/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@@ -73,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)@@ -122,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.@@ -131,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@@ -235,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@@ -275,7 +299,7 @@ , rsScrollRequests = esScrollRequests eState , observedNames = S.empty , renderCache = mempty- , clickableNames = []+ , clickableNames = mempty , requestedVisibleNames_ = requestedVisibleNames eState , reportedExtents = mempty }@@ -324,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@@ -436,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' @@ -452,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@@ -480,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/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,11 +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@@ -133,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 @@ -142,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@@ -155,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@@ -171,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@@ -187,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@@ -200,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'). --@@ -257,15 +244,9 @@ 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 @@ -309,13 +290,21 @@ case force theLines of [] -> return emptyResult multiple ->- let maxLength = maximum $ textWidth <$> 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 - textWidth 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 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. --@@ -337,7 +326,7 @@ -- input text should not contain escape sequences or carriage returns. txt :: T.Text -> Widget n txt s =- -- Althoguh vty Image uses lazy Text internally, using lazy text at this+ -- 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.@@ -350,10 +339,11 @@ [] -> emptyResult [one] -> emptyResult & imageL .~ (V.text' (c^.attrL) one) multiple ->- let maxLength = maximum $ V.safeWctwidth <$> multiple- lineImgs = lineImg <$> multiple- lineImg lStr = V.text' (c^.attrL)- (lStr <> T.replicate (maxLength - V.safeWctwidth lStr) (T.singleton ' '))+ 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.@@ -485,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@@ -495,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@@ -689,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@@ -713,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 @@ -728,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)@@ -759,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@@ -809,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@@ -820,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@@ -844,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@@ -992,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.@@ -1022,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@@ -1081,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@@ -1103,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@@ -1126,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@@ -1189,7 +1403,7 @@ result <- cacheLookup n case result of Just (clickables, prevResult) -> do- clickableNamesL %= (clickables ++)+ clickableNamesL %= (clickables <>) return prevResult Nothing -> do wResult <- render w@@ -1199,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@@ -1236,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.@@ -1294,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@@ -1324,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@@ -1392,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 @@ -1483,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)@@ -1506,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)@@ -1525,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@@ -1560,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,@@ -1569,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.@@ -1585,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@@ -1611,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@@ -1643,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@@ -1667,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@@ -1684,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@@ -1711,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@@ -1742,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/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,11 +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@@ -31,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@@ -51,6 +129,7 @@ , windowHeight = h , ctxBorderStyle = defaultBorderStyle , ctxAttrMap = aMap+ , ctxOrigAttrMap = aMap , ctxDynBorders = False , ctxVScrollBarOrientation = Nothing , ctxVScrollBarRenderer = Nothing@@ -62,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.@@ -107,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@@ -183,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/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