diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,98 +2,1963 @@ Brick changelog --------------- -0.2.3 ------ - -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 - handled sanely (fixes #22; reported by Hans-Peter Deifel) - -0.2.2 ------ - -Demo changes: -* Improved the list demo by using characters instead of integers in the - demo list and cleaned up item-adding code (thanks Jøhannes Lippmann - ) - -0.2.1 ------ - -Bug fixes: -* List: - * Fixed size policy of lists so that rather than being Fixed/Fixed, - they are Greedy/Greedy. This resolves issues that arise when the box - layout widget renders a list widget alongside a Fixed/Fixed one. - (Closes issue #17, thanks Karl Voelker) -* Scrolling: - * vScrollPage actually scrolls vertically now rather than horizontally - (Thanks Hans-Peter Deifel ) - -0.2 ---- - -API changes: -* Added top-level `Brick` module that re-exports the most important - modules in the library. -* List: - * Now instead of passing the item-drawing function to the `list` state - constructor, it is passed to `renderList` - * `renderList` now takes the row height of the list's item widgets. - The list item-drawing function must respect this in order for - scrolling to work properly. This change made it possible to optimize - the list so that it only draws widgets visible in the viewport - rather than rendering all of the list's items (even the ones - off-screen). But to do this we must be able to tell in advance - how high each one is, so we require this parameter. In addition - this change means that lists no longer support items of different - heights. - * The list now uses Data.Vector instead of [a] to store items; this - permits efficient slicing so we can do the optimized rendering - described above. -* The `HandleEvent` type class `handleEvent` method now runs in - `EventM`. This permits event-handling code implemented in terms of - `HandleEvent` to do get access to viewport state and to run IO code, - making it just as powerful as code in the top-level `EventM` handler. -* Many types were moved from `Brick.Widgets.Core` and `Brick.Main` to - `Brick.Types`, making the former module merely a home for `Widget` - constructors and combinators. -* The `IsString` instance for `Widget` was removed; this might be - reinstated later, but this package provides enough `IsString` - instances that things can get confusing. -* `EventM` is now reader monad over the most recent rendering pass's - viewport state, in addition to being a state monad over viewport - requests for the renderer. Added the `lookupViewport` function to - provide access to the most recent viewport state. Exported the - `Viewport` type and lenses. -* Now that `handleEvent` is now an `EventM` action, composition with - `continue` et al got a little messier when using lenses to - update the application state. To help with this, there is now - `handleEventLensed`. - -Bugfixes: -* Lists now perform well with 10 items or a million (see above; fixes - #7, thanks Simon Michael) -* Added more haddock notes to `Brick.Widgets.Core` about growth - policies. -* Forced evaluation of render states to address a space leak in the - renderer (fixes #14, thanks Sebastian Reuße ) -* str: only reference string content that can be shown (eliminates a - space leak, fixes #14, thanks Sebastian Reuße ) - -Misc: -* Added a makefile for the user guide. -* List: added support for Home and End keys (thanks Simon Michael) -* Viewports: when rendering viewports, scroll requests from `EventM` are - processed before visibility requests from the rendering process; this - reverses this previous order of operations but permits user-supplied - event handlers to reset viewports when desired. - -Package changes: -* Added `deepseq` dependency - -0.1 ---- +2.12 +---- + +Package changes: + +* Raised upper bound on microlens to allow building with 0.5. + +2.11 +---- + +Bug fixes: + +* Fixed a bug in FileBrowser: if a user pressed Enter when the cursor + was on a selected entry, it was omitted from the list of + selected browser entries. As part of this change, the function + `actionFileBrowserSelectCurrent` previously toggled the selection + of the entry at the cursor, but should have selected it instead. + It now does so, and a new function for toggling was introduced: + `actionFileBrowserToggleCurrent`. + +Other changes: + +* Upper bounds on `base` and `microlens` were adjusted. + +2.10 +---- + +* Updated `brick` to build with `microlens == 0.5.0.0` which moved its + Field* classes to `Lens.Micro.FieldN`. + +2.9 +--- + +API changes: +* Added `Brick.Widgets.List.listFindFirst` function. + +2.8.3 +----- + +Bug fixes: + +* Fixed a bug that completely broke `makeVisible` that was introduced + in brick 2.6. +* Fixed context cropping in `cropRightBy` and `cropBottomBy`. + +2.8.2 +----- + +* Updated `Brick.Widgets.Core` functions `cropBottomBy`, `cropToBy`, + `cropLeftBy`, and `cropRightBy` to properly perform result cropping to + actually address the internal bug fixed in 2.8.1. + +2.8.1 +----- + +* Fixed a long-standing bug in `cropToContext` that resulted in some + extents getting left around when they should be dropped, possibly + leading to application bugs when handling mouse clicks in extent + regions that should have been removed from the rendering result. + +2.8 +--- + +Behavior changes: +* `FileBrowser` file marking with `Space` now honors the file browser's + configured file selector predicate. +* `FileBrowser` file marking with `Space` and `Enter` now toggles file + selection rather than just selecting files, allowing for selected + files to be unselected. + +2.7 +--- + +This release adds `Brick.Animation`, a module providing infrastructure +for adding animations to Brick interfaces. See the Haddock documentation +in `Brick.Animation` for full details; see `programs/AnimationDemo.hs` +for a working example. + +2.6 +--- + +Behavior changes: + * `Brick.Widgets.Core.relativeTo` now draws nothing if the requested + extent is not found. Previously it would draw the specified widget in + the upper-left corner of the layer. + +Bug fixes: + * Fixed the conditional import in `BorderMap` (#519) + * `Brick.Widgets.Center.hCenterWith` now properly accounts for centered + image width when computing additional right padding (#520) + * The Brick renderer now properly resets some render-specific state + in between renderings that was previously kept around, avoiding + preservation of stale extents across renderings + * `brick-tail-demo` and `brick-custom-event-demo` now shut down Vty + properly + +2.5 +--- + +New features: +* `Brick.Widgets.ProgressBar` got a new function, `customProgressBar`, + which allows the customization of the fill characters used to draw a + progress bar. (Thanks @sectore) + +2.4 +--- + +Changes: +* The `Keybindings` API now normalizes keybindings + to lowercase when modifiers are present. (See also + https://github.com/jtdaugherty/brick/issues/512) This means that, + for example, a constructed binding for `C-X` would be normalized to + `C-x`, and a binding from a configuration file written `C-X` would be + parsed and then normalized to `C-x`. This is because, in general, when + modifiers are present, input events are received for the lowercase + version of the character in question. Prior to changing this, Brick + would silently parse (or permit the construction of) uppercase-mapped + key bindings, but in practice those bindings were unusable because + they are not generated by terminals. + +2.3.2 +----- + +Bug fixes: +* `FileBrowser`: if the `FileBrowser` was initialized with a `FilePath` + that ended in a slash, then if the user hit `Enter` on the `../` entry + to move to the parent directory, the only effect was the removal of + that trailing slash. This change trims the trailing slash so that the + expected move occurs whenever the `../` entry is selected. +* `Brick.Keybindings.Pretty.keybindingHelpWidget`: fixed a problem where + a key event with no name in a `KeyEvents` would cause a `fromJust` + exception. The pretty-printer now falls back to a placeholder + representation for such unnamed key events. + +2.3.1 +----- + +Bug fixes: +* Form field rendering now correctly checks for form field focus when + its visibility mode is `ShowAugmentedField`. + +2.3 +--- + +API changes: +* `FormFieldVisibilityMode`'s `ShowAugmentedField` was renamed to + `ShowCompositeField` to be clearer about what it does, and a new + `ShowAugmentedField` constructor was added to support a mode where + field augmentations applied with `@@=` are made visible as well. + +2.2 +--- + +Enhancements: +* `Brick.Forms` got a new `FormFieldVisibilityMode` type and a + `setFieldVisibilityMode` function to allow greater control over + how form field collections are brought into view when forms are + rendered in viewports. Form fields will default to using the + `ShowFocusedFieldOnly` mode which preserves functionality prior to + this release. To get the new behavior, set a field's visibility mode + to `ShowAugmentedField`. + +2.1.1 +----- + +Bug fixes: +* `defaultMain` now properly shuts down Vty before it returns, fixing + a bug where the terminal would be in an unclean state on return from + `defaultMain`. + +2.1 +--- + +API changes: + +* Added `Brick.Main.customMainWithDefaultVty` as an alternative way to + initialize Brick. + +2.0 +--- + +This release updates Brick to support Vty 6, which includes support for +Windows. + +Package changes: +* Increased lower bound on `vty` to 6.0. +* Added dependency on `vty-crossplatform`. +* Migrated from `unix` dependency to `unix-compat`. + +Other changes: +* Update core library and demo programs to use `vty-crossplatform` to + initialize the terminal. + +1.10 +---- + +API changes: +* The `ScrollbarRenderer` type got split up into vertical and horizontal + versions, `VScrollbarRenderer` and `HScrollbarRenderer`, respectively. + Their fields are nearly identical to the original `ScrollbarRenderer` + fields except that many fields now have a `V` or `H` in them as + appropriate. As part of this change, the various `Brick.Widgets.Core` + functions that deal with the renderers got their types updated, and + the types of the default scroll bar renderers changed, too. +* The scroll bar renderers now have a field to control how much space + is allocated to a scroll bar. Previously, all scroll bars were + assumed to be exactly one row in height or one column in width. This + change is motivated by a desire to be able to control how scroll + bars are rendered adjacent to viewport contents. It isn't always + desirable to render them right up against the contents; sometimes, + spacing would be nice between the bar and contents, for example. + As part of this change, `VScrollbarRenderer` got a field called + `scrollbarWidthAllocation` and `HScrollbarRenderer` got a field called + `scrollbarHeightAllocation`. The fields specify the height (for + horizontal scroll bars) or width (for vertical ones) of the region + in which the bar is rendered, allowing scroll bar element widgets + to take up more than one row in height (for horizontal scroll bars) + or more than one column in width (for vertical ones) as desired. If + the widgets take up less space, padding is added between the scroll + bar and the viewport contents to pad the scroll bar to take up the + specified allocation. + +1.9 +--- + +API changes: +* `FocusRing` got a `Show` instance. + +1.8 +--- + +API changes: +* Added `Brick.Widgets.Core.forceAttrAllowStyle`, which is like + `forceAttr` but allows styles to be preserved rather than overridden. + +Other improvements: +* The `Brick.Forms` documentation was updated to clarify how attributes + get used for form fields. + +1.7 +--- + +Package changes: +* Allow building with `base` 4.18 (GHC 9.6) (thanks Mario Lang) + +API changes: +* Added a new function, `Brick.Util.style`, to create a Vty `Attr` from + a style value (thanks Amir Dekel) + +Other improvements: +* `Brick.Forms.renderForm` now issues a visibility request for the + focused form field, which makes forms usable within viewports. + +1.6 +--- + +Package changes: +* Support `mtl` 2.3 (thanks Daniel Firth) + +API changes: +* `Brick.Widgets.Table` got a new `alignColumns` function that can be + used to do column layout of a list of widgets using `ColumnAlignment` + values from the table API. +* `Brick.Widgets.Table` got a new low-level table-rendering API for use + in applications that want to use the table layout machinery without + using `Table` itself. This includes: + * `tableCellLayout` - does table cell layout using table configuration + settings, + * `addBorders` - adds row, column, and surrounding borders using table + border-drawing settings, and + * `RenderedTableCells` and `BorderConfiguration` - the low-level types + used for the new functions. + +Other changes: +* Added a new `EditorLineNumbersDemo` demo program. + +1.5 +--- + +This release focuses on API improvements in `Brick.Widgets.Dialog`: + +* `Dialog` got an additional type argument, `n`, for resource names. +* The `dialog` constructor now takes `[(String, n, a)]` rather than + `[(String, a)]`; this allows the caller to associate a resource name + with each dialog button. +* Dialog buttons now report click events under their associated resource + names. +* Dialog buttons now `putCursor` when they are focused in order to work + better with screen readers. +* The `Dialog` module got `getDialogFocus` and `setDialogFocus` + functions to help with focus management, and as part of this change, + the `dialogSelectedIndex` function and its lens `dialogSelectedIndexL` + were removed. + +1.4 +--- + +API changes: +* `Brick.Widgets.Border` got `hBorderAttr` and `vBorderAttr` for use by + `hBorder` and `vBorder` respectively. The new attributes inherit from + `borderAttr`, so applications that just specify `borderAttr` will not + see any change in behavior for those specific border elements. + +Performance improvements: +* `Brick.Widgets.Core.txt` had its performance improved. (thanks Fraser + Tweedale) +* `Brick.Widgets.Core.hBox` and `vBox` had their performance improved. + (thanks Fraser Tweedale) + +1.3 +--- + +Package changes: +* Removed dependency on `dlist`. + +Performance improvements: +* Improved the performance of `vBox` and `hBox` (thanks Fraser Tweedale) + +1.2 +--- + +Package changes: +* Supports base 4.17 (GHC 9.4). + +Bug fixes: +* `newFileBrowser` now normalizes its initial path (#387). + +1.1 +--- + +API changes: +* `keyDispatcher` now returns `Either` to fail with collision + information if collisions are detected due to overloaded keybindings. + This fixes a critical problem in `KeyDispatcher` where it would + previously silently ignore all but one handler for a specified key + if the key configuration resulted in the same key being mapped to + multiple handlers (either by event or by statically specified key). +* Added `Brick.Keybindings.KeyConfig.keyEventMappings` to allow + applications to check for colliding bindings at the key configuration + level. + +Other changes: +* The User Guide got a new subsection on keybinding collisions. +* `programs/CustomKeybindingDemo.hs` got additional code to demonstrate + how to check for and deal with keybinding collisions. +* `FileBrowser` got a `Named` instance. + +1.0 +--- + +Version 1.0 of `brick` comes with some improvements that will require +you to update your programs. This section details the list of API +changes in 1.0 that are likely to introduce breakage and how to deal +with each one. You can also consult the demonstration +programs to see working examples of the new API. For those +interested in a bit of discussion on the changes, see [this +ticket](https://github.com/jtdaugherty/brick/issues/379). + +* The event-handling monad `EventM` was improved and changed in some + substantial ways, all aimed at making `EventM` code cleaner, more + composable, and more amenable to lens updates to the application + state. + * The type has changed from `EventM n a` to `EventM n s a` and is now + an `mtl`-compatible state monad over `s`. Some consequences and + related changes are: + * Event handlers no longer take and return an explicit state value; + an event handler that formerly had the type `handler :: s -> + BrickEvent n e -> EventM n (Next s)` now has type `handler :: + BrickEvent n e -> EventM n s ()`. This also affected all of + Brick's built-in event handler functions for `List`, `Editor`, + etc. + * The `appHandleEvent` and `appStartEvent` fields of `App` changed + types to reflect the new structure of `EventM`. `appStartEvent` + will just be `return ()` rather than `return` for most + applications. + * `EventM` can be used with the `MonadState` API from `mtl` as well + as with the very nice lens combinators in `microlens-mtl`. + * The `Next` type was removed. + * State-specific event handlers like `handleListEvent` and + `handleEditorEvent` are now statically typed to be scoped to + just the states they manage, so `zoom` from `microlens-mtl` must + be used to invoke them. `Brick.Types` re-exports `zoom` for + convenience. `handleEventLensed` was removed from the API in lieu + of the new `zoom` behavior. Code that previously handled events + with `handleEventLensed s someLens someHandler e` is now just + written `zoom someLens $ someHandler e`. + * If an `EventM` block needs to operate on some state `s` that is + not accessible via a lens into the application state, the `EventM` + block can be set up with `Brick.Types.nestEventM`. + * Since `Next` was removed, control flow is now as follows: + * Without any explicit specification, an `EventM` block always + continues execution of the `brick` event loop when it finishes. + `continue` was removed from the API. What was previously `continue + $ s & someLens .~ value` will become `someLens .= value`. + * `halt` is still used to indicate that the event loop should halt + after the calling handler is finished, but `halt` no longer takes + an explicit state value argument. + * `suspendAndResume` is now immediate; previously, + `suspendAndResume` indicated that the specified action should run + once the event handler finished. Now, the event handler is paused + while the specified action is run. This allows `EventM` code to + continue to run after `suspendAndResume` is called and before + control is returned to `brick`. + * Brick now depends on `mtl` rather than `transformers`. +* The `IsString` instance for `AttrName` was removed. + * This change is motivated by the API wart that resulted from the + overloading of both `<>` and string literals (via + `OverloadedStrings`) that resulted in code such as `someAttrName + = "blah" <> "things"`. While that worked to create an `AttrName` + with two segments, it was far too easy to read as two strings + concatenated. The overloading hid what is really going on with the + segments of the attribute name. The way to write the above example + after this change is `someAttrName = attrName "blah" <> attrName + "things"`. + +Other changes in this release: + +* Brick now provides an optional API for user-defined keybindings + for applications! See the User Guide section "Customizable + Keybindings", the Haddock for `Brick.Keybindings.KeyDispatcher`, + and the new demo program `programs/CustomKeybindingDemo.hs` to get + started. +* `Brick.Widgets.List` got `listSelectedElementL`, a traversal for + accessing the currently selected element of a list. (Thanks Fraser + Tweedale) +* The `MonadFail` derived instance for `EventM` was removed for GHC >= + 8.8. + +0.73 +---- + +API changes: + * Added `Brick.Widgets.Edit.getCursorPosition` (thanks + @TristanCacqueray) + +0.72 +---- + +Package changes: + * Increased lower bound on `text-zipper` to `0.12`. + +API changes: + * `handleEditorEvent` now takes a `BrickEvent` rather than just a Vty + `Event`. + * Brick editors now handle mouse clicks to change their cursor + positions. + +0.71.1 +------ + +Bug fixes: + * Fixed an issue where `tests/Render.hs` did not gracefully exit in the + presence of an unknown terminal. + +0.71 +---- + +Package changes: + * Increased `vty` lower bound to `5.36`. + +API changes: + * Added `tests/Render.hs` to provide a simple test of + `Brick.Main.renderWidget` (thanks @valyagolev) + * Added `Brick.Main.renderWidget` to help in golden testing contexts + (thanks @valyagolev) + +Other changes: + * Various `table` documentation improvements. + +0.70.1 +------ + +Build fixes: + * Added a missing import for GHC 8.2.2. + +0.70 +---- + +Enhancements: + * The table widget now behaves much better when some or all cells are + empty. + +Bug fixes: + * BorderMaps got fixed to ensure that smart borders connect even in the + presence of empty widgets (#370). Thanks to Daniel Wagner for this + fix! + +0.69.1 +------ + +Bug fixes: + * `table` can now deal properly with empty cells that are in left- and + top-aligned settings. Previously, empty cells in those settings would + break table rendering. (#369) + +0.69 +---- + +New features: + * `Brick.Widgets.Core`: added `relativeTo` to support relative + positioning across layers. This allows elements in higher layers + to be positioned relative to elements in lower layers as long as + those elements have had their extents reported with `reportExtent` or + `clickable`. + +0.68.1 +------ + +Bug fixes: + * Brick's internal book-keeping got a bug fix that caused mouse-click + coordinates to be wrong for clickable regions that were translated + partially off of the left or top edges of a rendered region. + +0.68 +---- + +API changes: + * Removed the "markup" feature, which included `Data.Text.Markup`, + `Brick.Markup`, and `brick-markup-demo`. This feature never performed + well and was awkward to use. I considered it experimental from the + initial release of this library. Some recent incompatibilities with + Vty changes made me realize that it was time to finally get rid of + this. If this affects you, please let me know and I am happy to work + with you to figure out an alternative. Granted, anyone is welcome to + dig up the previous code and re-use it in their own projects! + +0.67 +---- + +API changes: + * `Brick.Widgets.FileBrowser` now exports getters for all + `FileBrowser` fields. These getters are lens-like accessors + with the `G` suffix. + * `Brick.Widgets.FileBrowser` no longer exports the + `fileBrowserEntryFilterL` lens. The lens broke the API + because it allowed modification of internal state that could + lead to inconsistency in the UI. Users who needed to use + `fileBrowserEntryFilterL` before this change should use + `setFileBrowserEntryFilter` instead. + +0.66.1 +------ + +Bug fixes: + * `Brick.Widgets.Core.cached` no longer caches the visibility requests + generated by the cached image. This fixes a bug where re-use of a + cached rendering would cause undesired viewport scrolling of those + requested regions into view when the cached renderings got re-used. + +0.66 +---- + +New features: + * Added `Brick.Main.makeVisible`, a function to request visible regions + from `EventM`. This, together with `Brick.Widgets.Core.reportExtent`, + can be used to request that a viewport be scrolled to make a + specified named region visible on the next redraw. The region must be + known to the renderer with `reportExtent` (or something that calls + it, like `clickable`). Due to the `Ord` constraint on some of the API + calls required to implement this, an `Ord` constraint on the resource + name type (`n`) got propagated to various places in the API. But that + shouldn't present a problem since other fundamental API calls already + required that instance. + +0.65.1 +------ + +Bug fixes: + * `Brick.Widgets.Core.viewport`: fixed non-scroll + direction width/height in the presence of scroll bars (see + e41ad936ebe8b49e259a72ff7a34765d5a587aaa). + +0.65 +---- + +New features and API changes: + * Viewports got support for built-in scroll bar rendering. This + includes additions of types and functions to manage the feature + behavior. These changes enable viewports to automatically get + scroll bars drawn next to them (on any side) with customizable + attributes and drawings. As part of this change, a new demo program, + `ViewportScrollbarsDemo.hs`, was added to show off these new + features. Here are the new types and functions that got added (mostly + to `Brick.Widgets.Core`): + * `withVScrollBars` - enable display of vertical scroll bars + * `withHScrollBars` - enable display of horizontal scroll bars + * `withClickableVScrollBars` - enable mouse click reporting on + vertical scroll bar elements + * `withClickableHScrollBars` - enable mouse click reporting on + horizontal scroll bar elements + * `ClickableScrollbarElement` - the type of elements of a scroll bar + that can be clicked on and provided to the application + * `withVScrollBarHandles` - enable vertical scroll bar handle drawing + * `withHScrollBarHandles` - enable horizontal scroll bar handle + drawing + * `withVScrollBarRenderer` - customize the renderer used for vertical + scroll bars + * `withHScrollBarRenderer` - customize the renderer used for + horizontal scroll bars + * `ScrollbarRenderer(..)` - the type of scroll bar renderer + implementations + * `verticalScrollbarRenderer` - the default renderer for vertical + scrollbars, customizable with `withVScrollBarRenderer` + * `horizontalScrollbarRenderer` - the default renderer for horizontal + scrollbars, customizable with `withHScrollBarRenderer` + * `scrollbarAttr` - the base attribute of scroll bars + * `scrollbarTroughAttr` - the attribute of scroll bar troughs + * `scrollbarHandleAttr` - the attribute of scroll bar handles + * The `Context` type got the `n` type argument that is used for + `Result`, `EventM`, etc. + +Package changes: + * Raised `base` bounds to allow building with GHC 9.2.1 (thanks Mario + Lang) + * Stopped supporting GHC 7.10. + +0.64.2 +------ + +Bug fixes: + * `Brick.Themes.saveTheme` now correctly saves background colors (#338) + * `Brick.Widgets.List.listMoveToEnd` now uses the correct destination + index (#337) + +0.64.1 +------ + +Bug fixes: + * Fixed a bug where mouse clicks could fail to be noticed if + "continueWithoutRedraw" was called. + +0.64 +---- + +API changes: + * Added `Brick.Main.continueWithoutRedraw`, an alternative to + `Brick.Main.continue` that does not trigger a screen redraw. See the + Haddock and User Guide for details. + * Added `Brick.Widgets.Core.putCursor` to support Vty's new (as of + 5.33) API for placing cursors without visually representing + them. This change also updated `Brick.Forms.renderCheckbox` and + `Brick.Forms.renderRadio` to use `putCursor` (thanks to Mario Lang + for this work). + +Other improvements: + * `Brick.Widgets.Edit` now supports a few more Emacs-style keybindings + (thanks Mario Lang): + * `M-b` and `M-f` to navigate by word + * `C-b` and `C-f` for consistency + * `M-d` to delete word under cursor + * `C-t` to transpose previous character with current character + * `M-<` and `M->` to goto-beginning-of-file and end of file, + respectively + +0.63 +---- + +API changes: + * The `Viewport` type got a new field, `_vpContentSize` (and a + corresponding lens `vpContentSize`) to get the size of the viewport's + contents. + +0.62 +---- + +API changes: + * `Brick.Widgets.Core` got new functions + `crop{Left,Right,Bottom,Top}To`. Unlike the `crop...By` functions, + which crop on the specified side by a particular amount, these + `crop...To` functions crop on the specified side and take a desired + overall width of the final result and use that to determine how much + to crop. A widget `x` of width `w` could thus be cropped equivalently + with `cropLeftBy a x` and `cropLeftTo (w - a) x`. + +Other changes: + * Added `programs/CroppingDemo.hs` to demonstrate the new (and + preexisting) cropping functions. + +0.61 +---- + +API changes: + * Brick.Forms got `editShowableFieldWithValidate`, a generalization + of `editShowableField` that allows the caller to specify an + additional validation function (thanks Ben Selfridge) + +0.60.2 +------ + +Bug fixes: + * Widgets reported as `clickable` are now reported as clickable even + when their renderings are cached with `cached` (#307; thanks Hari + Menon) + +0.60.1 +------ + +Bug fixes: + * `table []` no longer raises `TEUnequalRowSizes`. + +0.60 +---- + +New features: + * Added `Brick.Widgets.Table` to support drawing basic tables. See + `programs/TableDemo.hs` for a demonstration (`cabal new-run -f demos + brick-table-demo`). + +0.59 +---- + +API changes: + * `Brick.Widgets.List` got `listMoveToBeginning` and `listMoveToEnd` + functions + * `Extent`: removed the unused `extentOffset` field + +Bug fixes: + * Fixed a crash in the border rewriting code that attempted to rewrite + empty images (#305) (thanks @dmwit) + +0.58.1 +------ + +Bug fixes: + * Removed a defunct failing test from the List test suite + +0.58 +---- + +Package changes: + * Updated dependency constraints to build on GHC 9.0.1 (thanks Ondřej + Súkup) + +API changes: + * The FileBrowser module now exports individual functions for + each of the events that it handles. This allows end users to + trigger the behaviors directly rather than relying on the built-in + `handleFileBrowserEvent` function. The documentation has been updated + to indicate which functions are triggered by each key event. (Thanks + David B. Lamkins) + +Other changes: + * The `List` module's `listFindBy` function now attempts to find a + match anywhere in the list rather than just somewhere between the + cursor and the end of the list. + * The `FileBrowser` now positions a cursor at the beginning of the + selected entry when the file browser is focused. (thanks Mario Lang) + * The user guide's viewport visibility example got an important + syntactic fix. (thanks Mario Lang) + +0.57.1 +------ + +Bug fixes: + * Fixed a small space leak in the main rendering loop (#260) + * Get `TailDemo` building on more versions of GHC + +0.57 +---- + +Package changes: + * Raised lower bound on `vty` to 5.31 to get the new `strikethrough` + style. + +New features: + * Added support for the `strikethrough` style in Brick theme + customization files. + +0.56 +---- + +Package changes: + * Increased upper bound for `base` to support GHC 8.10.2 (thanks Ryan + Scott) + +API changes: + * Added `Brick.Forms.updateFormState` to update the state contained + within (and managed by) a Form. This function takes care of the + details of updating the form fields themselves to be consistent with + the change in underlying state. + * Added the overall window width (`windowWidth`) and height + (`windowHeight`) to `Context`, the rendering context type (thanks Tom + McLaughlin) + +Other changes: + * Added `brick-tail-demo`, a demonstration program for writing a + `tail`-style output-following interface. + * Updated `Brick.Widgets.ProgressBar` so that it handles near-endpoint + cases more naturally (fixes #281) + +0.55 +---- + +Package changes: + * Increased lower bound on `vty` dependency to 5.29. + +Bug fixes: + * `customMain` now restores the initial terminal input state on + shutdown. This means that changes to the input state flags in the last + `suspendAndResume` before program exit are no longer propagated to the + end user's terminal environment (which could lead to broken or garbled + terminal I/O). + +0.54 +---- + +API changes: + * Exported `Brick.Widgets.FileBrowser.maybeSelectCurrentEntry` (thanks + Róman Joost) + +Other changes: + * Added handlers for the `Home` and `End` keys to + `Brick.Widgets.Edit.handleEditorEvent` (thanks Róman Joost) + +0.53 +---- + +Package changes: + * Relaxed base bounds to allow building with GHC 8.10 (thanks Joshua + Chia) + +Bug fixes: + * `vLimitPercent`: use correct horizontal size policy from child + (thanks Janek Spaderna) + * `str`: be more aggressive in determining how many characters to + display (attempt to display as many zero-width characters as + possible) + +0.52.1 +------ + +Bug fixes: + * Attribute map lookups now merge styles in addition to merging colors + (see `eb857e6bb176e119ac76f5e2af475f1b49812088`). + * `txtWrapWith` now pads in the single-line case (see also + `926d317c46b19d4e576748891a1702080287aa03`, #234, and #263) + +0.52 +---- + +API changes: + * EventM now provides a MonadFail instance + * EventM now provides MonadMask, MonadCatch, and MonadThrow instances + (thanks Fraser Tweedale) + +Other changes: + * The FileBrowser now has support for vi-style bindings in addition to + its previous bindings. New bindings include: + * `j`/`k`: next/previous element + * `C-n`/`C-p`: page down/up + * `C-d`/`C-u`: half page down/up + * `g`: select first entry + * `G`: select last entry + +0.51 +---- + +API changes: + * Added Brick.Focus.focusRingToList, which returns all of the elements + in a focus ring as a list, starting with the focused entry and + wrapping around (#257; thanks @4eUeP) + +Bug fixes: + * Fix Brick.Widgets.FileBrowser.fileExtensionMatch to match directories + and also match symlinks that link to directories (thanks @YVee1) + +Other changes: + * Added demonstration program screenshot gallery (thanks @drola) + +0.50.1 +------ + +Bug fixes: + * Fixed a bug where a self-referential symlink would cause the file + browser to get into a loop and ultimately crash. (Thanks Kevin Quick) + +API changes: + * Added `Brick.Focus.focusRingLength` to get the size of a focus ring. + (Thanks Róman Joost) + +Other changes: + * Updated Travis configuration and base dependency to support GHC + 8.8.1. (thanks Brandon Hamilton) + +0.50 +---- + +API changes: + * Added `writeBChanNonBlocking`, which does a non-blocking write to a + `BChan` and returns whether the write succeeded. This required + raising the STM lower bound to 2.4.3. + +0.49 +---- + +New features: + * The `FileBrowser` now supports navigation of directories via + symlinks, so `Enter` on a symlink will descend into the target path + of the symlink if that path is a directory. Part of this change is + that the `FileInfo` type got a new file, `fileInfoLinkTargetType`, + that indicates the type of file that the link points to, if any. + +0.48 +---- + +New features: + * The `Edit` widget now supports `EvPaste` Vty events by default, + assuming UTF-8 encoding of pasted bytes. If pasted bytes are not + UTF-8-decodable, the pastes will be ignored. In any case, users can + still intercept `EvPaste` events as before and handle them as desired + if the default behavior is not desirable. + +Other changes: + * `txtWrapWith` now always pads its output to the available width to + obey its `Greedy` requirement. + +0.47.1 +------ + +Bug fixes: + * userguide: update stale Result construction + * Added test case for List initial selection (thanks Fraser Tweedale) + * Fixed build on GHC 7.10 due to RULES pragma formatting issue (thanks + Fraser Tweedale) + * Various CI-related fixes (thanks Fraser Tweedale) + +0.47 +---- + +API changes: + * Changed `Brick.Main.customMain` so that it now takes an additional + (first) argument: the initial `Vty` handle to use. This lets the + caller have more control over the terminal state when, for example, + they have previously set up Vty to do other work before calling + `customMain`. + * Added `Brick.Main.customMainWithVty`. This function is the same as + `customMain` except that it also returns the final `Vty` handle that + it used internally *without* shutting that Vty handle down. This + allows the caller to continue using the terminal without resetting it + after `customMainWithVty` finishes executing. + +0.46 +---- + +Performance improvements: + * The box combinators `<=>`, `<+>`, `vBox`, and `hBox` got GHC rewrite + rules that will optimize away redundant boxes. This change improves + performance for chains of `<+>` or `<=>` as well as nested boxes + using `hBox` and `vBox`. Previously chains of e.g. `<+>` produced + binary trees of boxes that incurred more rendering overhead. Those + are now optimized away. + +API changes: + * Data.Text.Markup: renamed `empty` to `isEmpty` + +0.45 +---- + +API changes: + * List got a new `listFindBy` function (thanks Fraser Tweedale). This + function uses a predicate to find a matching element in the list and + move the cursor to that item. + * Data.Text.Markup got a new `empty` function (#213) + +0.44.1 +------ + +Bug fixes: + * `Brick.Markup` now properly renders empty lines in markup (#209) + +0.44 +---- + +API changes: + * The `List` type got its container type generalized thanks to a lot of + work by Fraser Tweedale. Note that this change is + backwards-compatible with older Brick programs that use the `List`. + Thanks to this work, the `List` now supports both `Data.Vector` + and `Data.Sequence` as its container types out of the box and can + be extended to support other sequence types with some simple type + class instances. In addition, property tests are provided for `List` + and its asymptotics are noted in the documentation. Along the way, + various bugs in some of the list movement functions got fixed to + bring them in line with the advertised behavior in the documentation. + Thanks, Fraser! + +0.43 +---- + +API changes: + * The FileBrowser module got the ability to select multiple files + (#204). This means that the `fileBrowserSelection` function now + returns a list of `FileInfo` rather than at most one via `Maybe`. + The module also now uses a new attribute, `fileBrowserSelectedAttr`, + to indicate entries that are currently selected (in addition to + displaying an asterisk after their filenames). Lastly, the file + size and type fields of `FileInfo` have been replaced with a + new type, `FileStatus`, and `FileInfo` now carries an `Either + IOException FileStatus`. As part of that safety improvement, + `setWorkingDirectory` now no longer clobbers the entire entry listing + if any of the listings fail to stat. In addition, the FileBrowser now + uses the correct file stat routines to deal with symbolic links. + +Package changes: + * Added lower bound on `directory` (thanks Fraser Tweedale) + +Test suite changes: + * Test suite now propagates success/failure to exit status (thanks + Fraser Tweedale) + +0.42.1 +------ + +Behavior changes: + * File browsers in search mode now terminate search mode when `Enter` + is pressed, resulting in better behavior. + +0.42 +---- + +New features: + * Added `Brick.Widgets.FileBrowser`, which provides a filesystem + browser for selecting files and directories. Read the Haddock + module documentation and see the included demo program, + `programs/FileBrowserDemo.hs`, for information on using the new + functionality. + +0.41.5 +------ + +Miscellaneous: + * `suspendAndResume` now empties the rendering cache when returning to + the rendering event loop. This ensures that the state returned by the + `IO` action is rendered completely rather than relying on potentially + stale cache entries. + +0.41.4 +------ + +API changes: + * Forms: added `setFormFocus` function to set focus for a form + * Added `NFData` instances for `AttrMap` and `Theme` types (thanks + Fraser Tweedale) + +0.41.3 +------ + +Bug fixes: + * Lists now draw correctly without crashing due to a vector slice + bounds check failure if their rendering area is too small (#195; + thanks @andrevdm) + +Other changes: + * Relaxed base bounds to support GHC 8.6 (thanks @maoe) + * Added towerHanoi to the featured projects list + +0.41.2 +------ + +Bug fixes: + * Support STM 2.5 by allowing for `Natural` argument to `newTBQueue` + (thanks @osa1) + +0.41.1 +------ + +New features: + * `Forms`: added `checkboxCustomField` and `radioCustomField` to permit + customization of characters used to draw selection state for such + fields. + +0.41 +---- + +New features: + * `Brick.Forms` got a new field constructor, `listField`, that provides + a form field using a `List`. + * `List`: added the `listMoveToElement` function for changing the list + selection to the specified element, if it exists. + +Package changes: + * Now depends on vty >= 5.24. + +Other changes: + * `viewport`: fixed failable patterns for forward compatibility with + GHC 8.6 (#183) + * Add `Generic`, `NFData`, and `Read` instances for some types + +0.40 +---- + +New features: + * Brick.Widgets.Core: added new functions `hLimitPercent` and + `vLimitPercent`. These behave similarly to `hLimit` and `vLimit` + except that instead of taking absolute numbers of columns or rows, + they take percentages. (Thanks Roman Joost) + +0.39 +---- + +New features: + * The `italic` keyword is now supported in theme customization file + style lists. This requires `vty >= 5.23.1` + +0.38 +---- + +New features: + * Added support for parsing `#RRGGBB` color values in theme + customization files in addition to the color names already supported + (thanks Brent Carmer). These values are mapped to the nearest + reasonable entry in the 240-color space. + +0.37.2 +------ + +Bug fixes: + * Theme customization files can now use empty lists for style + customization. + +0.37.1 +------ + +API changes: + * Exposed `Brick.Forms.renderFormFieldState`. + +0.37 +---- + +Behavior changes: + * `listMoveBy` now automatically moves to the first or last position + in the list if called when the list is non-empty but has no selected + element (thanks Philip Kamenarsky) + +API changes: + * Added `Brick.Widgets.List.renderListWithIndex` that passes + the index of each element to the item rendering function (thanks + liam@magicseaweed.com) + +0.36.3 +------ + +Bug fixes: + * Fixed a bug where mouse-up events in viewports were not translated + into the global coordinate space, unlike mouse-down events (#173) + +0.36.2 +------ + +API changes: + * The Forms API got two new functions, `setFormConcat` and + `setFieldConcat`, used for controlling the previously hard-coded + concatenation behavior of form fields. These are optional and both + concatenation settings default to their former hard-coded values, + `vBox` (#172). + +0.36.1 +------ + +Package changes: + * Raised upper bound to support GHC 8.4.2 (#171) + +Other changes: + * Improved List accessor documentation (thanks liam ) + * Brick.Main now uses a Set instead a list to track invalidation + requests to avoid duplicates. + +0.36 +---- + +New features: + * Dynamic border support: adjacent widgets that use borders can make + those borders seamlessly connect to each other! Thanks + so much to Daniel Wagner for this feature! Please see + `programs/DynamicBorderDemo.hs` for a demonstration. Also see the + "Joinable Borders" section of the User Guide. + +0.35.1 +------ + + * Conditionally depend on semigroups for GHC before 8 + +0.35 +---- + + * Added support for GHC 8.4. + * Updated travis build to test on all 8.x releases (thanks Peter + Simons) + +0.34.1 +------ + +Bug fixes: + * Fixed a bug where the "reverseVideo" style could not be parsed in a + theme customization when it was all lowercase (thanks Yuriy Lazarev) + +Documentation changes: + * Guide: added more complete example of creating a default theme + (thanks Mark Wales) + * Guide: added offset to Extent pattern matching (thanks Mark Wales) + +0.34 +---- + +API changes: + * Core: vLimit and hLimit now *bound* sizes rather than setting them. + This was the original intention of these combinators. The change in + behavior means that now `vLimit N` means that *at most* `N` rows will + be available; if the context has less, then the smaller constraint in + the context is used instead. Programs affected by this behavior will + be those that assume that `vLimit` doesn't do this, but that should + be very few or zero. + +Other changes: + * Dialog: now arrow keys no longer wrap around available buttons but + stop at rightmost or leftmost button to avoid confusion when + attempting to tell which button is selected in two-button dialogs + (thanks to Karl Ostmo for this change) + +Documentation changes: + * Updated Haddocks for str/txt in Core to mention tab character + considerations + +0.33 +---- + +API changes: + * Forms: added support for external validation of form fields using + `setFieldValid`. See the Haddock, User Guide, and FormDemo.hs for + details. + * Borders: removed all attribute names except `borderAttr` to simplify + border attribute assignment. + +0.32.1 +------ + +Bug fixes: + * Core: make all text wrap widgets Greedy horizontally + +Miscellaneous: + * Dialog: clarify purpose in documentation (w.r.t. #149) + +0.32 +---- + +API changes: + * This release adds the new `Brick.Forms` module, which provides an API + for type-safe input forms with automatic rendering, event handling, + and state management! See the Haddock and the "Input Forms" section + of the Brick User Guide for information on this killer feature! Many + thanks to Kevin Quick for feedback on this new functionality. + +0.31 +---- + +Behavior changes: + * `viewport` now implicitly causes generation of mouse events for the + viewport when mouse mode is enabled. The mouse events are expressed + in the coordinate system of the contents of the viewport. The + consequence and intention of this change is to enable mouse event + reporting for editors when clicks occur outside the known text area. + +0.30 +---- + +API changes: + * `Brick.Focus`: added `focusSetCurrent` to make it easy to set the + focus of a focus ring + * `Brick.Main`: added a simple polymorphic `App` value, `simpleApp` + +0.29.1 +------ + +Bug fixes: + * Mixed-case color names like "brightBlue" can now be parsed in theme + customization files. + +0.29 +---- + +API changes: + * Added Ord instances for `Location` and `BrickEvent` (thanks Tom + Sydney Kerckhove) + * `Brick.AttrMap`: attribute name components are now exposed via the + `attrNameComponents` function. Also added a Read instance for + AttrName. + +New features: + * This release adds user-customizable theme support. Please see the + "Attribute Themes" section of the User Guide for an introduction; see + the Haddock documentation for `Brick.Themes` for full details. Also, + see the new `programs/ThemeDemo.hs` for a working demonstration. + +0.28 +---- + +API changes: + * Brick.AttrMap.setDefault was renamed to setDefaultAttr. + * Added Brick.AttrMap.getDefaultAttr: get the default attribute from an + attribute map. + * Added Brick.Widgets.Core.modifyDefAttr to modify the default + attribute of the rendering context. + +Other changes: + * Updated AttrDemo to show usage of modifyDefAttr. + +0.27 +---- + +API changes: + * Brick.Widgets.Core: added `hyperlink` combinator (thanks Getty Ritter + for hyperlinking support) + +Other changes: + * Updated AttrDemo to show how to use hyperlinking + * README: Added `herms` to featured projects + +0.26.1 +------ + + * Fixed haddock for listHandleEventVi. + +0.26 +---- + +API changes: + * Added Brick.Widgets.List.handleListEventVi to add support for + vi-style movements to lists (thanks Richard Alex Hofer) + +Other changes: + * Added ListViDemo.hs to demonstrate the Vi-style handler for lists + (thanks Richard Alex Hofer) + +0.25 +---- + +API changes: + * List: added page movement functions `listMoveByPages`, + `listMovePageUp`, and `listMovePageDown` (thanks Richard Alex Hofer) + +Miscellaneous: + * Fixed a spelling mistake in the AttrMap haddock (thanks Edward Betts) + +0.24.2 +------ + +Miscellaneous: + * Minor documentation updates including a clarification for #135 + +0.24.1 +------ + +Bug fixes: + * vBox/hBox: when there is leftover space and all elements are greedy, + spread it amongst the elements as evenly as possible instead of + assigning it all to the first element (fixes #133) + +Package changes: + * Include Sam Tay's brick tutorial files in extra-doc-files + +0.24 +---- + +API changes: + * Added Brick.Widgets.Core.setAvailableSize to control rendering + context size in cases where the screen size is too constraining (e.g. + for a floating layer that might be bigger than the screen). + +Documentation changes: + * Samuel Tay has contributed his wonderful Brick tutorial to this + package in docs/samtay-tutorial.md. Thank you! + +0.23 +---- + +API changes: + * getVtyHandle: always return a Vty handle rather than Maybe + (Previously, in appStartEvent you'd get Nothing because Vty had + not been initialized yet. This made various use cases impossible + to satisfy because appStartEvent is a natural place to get initial + terminal state from Vty. This change makes it so that a Vty handle is + always available, even in appStartEvent.) + * txtWrapWith: added missing haddock + +0.22 +---- + +API changes: + * Core: added txtWrapWith and strWrapWith functions to provide control + over wrapping behavior by specifying custom wrapping settings. + +Other changes: + * Updated TextWrapDemo.hs to demonstrate customizing wrapping settings. + +0.21 +---- + +Package changes: + * Upgrade to word-wrap 0.2 + +Other changes: + * Brick.Types.Internal: improve mouse constructor haddock + * Add a basic fill demonstration program (FillDemo.hs) + +0.20.1 +------ + +Bug fixes: + * str: fixed an IsString constraint confusion on GHC 7.10.1 + +0.20 +---- + +Package changes: + * Added a dependency on "word-wrap" for text-wrapping. + * Added a new TextWrapDemo demo program to illustrate text wrapping + support + +API changes: + * Brick.Widgets.Core: added new functions txtWrap and strWrap to do + wrapping of long lines of text. + +Miscellaneous: + * Guide: fixed event type (#126) + +0.19 +---- + +API changes: + * The editor content drawing function is now passed to renderEditor, + not the constructor, to improve separation of presentation and + representation concerns. The corresponding Editor drawing function + lens and accessor were removed. + +0.18 +---- + +Package changes: + * Added a dependency on data-clist. + +API changes: + * Brick.Focus: removed the Functor instance for FocusRing. + * Brick.Focus: re-implemented FocusRing in terms of the circular list + data structure from data-clist. In addition, this change introduced + "focusRingModify", which permits the user to use the data-clist API + to directly manipulate the FocusRing's internals. This way brick + doesn't have to re-invent the wheel on the focus ring behavior. + +0.17.2 +------ + +Package changes: + * Added programs/ReadmeDemo.hs and featured its output and code in the + README to provide an early demonstration + +Library changes: + * centerAbout now right- and bottom-pads its operand to behave + consistently with h/vCenter + +0.17.1 +------ + +Package changes: + * Use Extra-Doc-Files instead of Data-Files for documentation files + +Bug fixes: + * List: correctly update selected index in listInsert + * Update example program in brick.cabal (thanks @timbod7) + +0.17 +---- + +Package changes: +* Updated to depend on Vty 5.15. +* Updated to remove dependency on data-default. +* Discontinued support for GHC versions prior to 7.10.1. + +API changes: +* Removed Data.Default instances for AttrName, AttrMap, Result, and + BorderStyle (use Monoid instances instead where possible). +* Added defaultBorderStyle :: BorderStyle. +* Added emptyResult :: Result n. + +0.16 +---- + +This release includes a breaking API change: +* Brick now uses bounded channels (Brick.BChan.BChan) for event + communication rather than Control.Concurrent.Chan's unbounded channels + to improve memory consumption for programs with runaway event + production (thanks Joshua Chia) + +Other API changes: +* Brick.List got a new function, listModify, for modifying the selected + element (thanks @diegospd) + +Performance improvements: +* hBox and vBox now use the more efficient DList data structure when + rendering to improve performance for boxes with many elements (thanks + Mitsutoshi Aoe) + +0.15.2 +------ + +Bug fixes: +* viewport: do not cull cursor locations on empty viewport contents + (fixes #105) +* User guide CounterEvent type fix (thanks @diegospd) + +0.15.1 +------ + +Bug fixes: +* List: fixed empty list validation in listReplace (thanks Joshua Chia) + +0.15 +---- + +Demo changes: +* MouseDemo: add an editor and use mouse events to move the cursor +* MouseDemo: Enhance MouseDemo to show interaction between 'clickable' + and viewports (thanks Kevin Quick) + +New features: +* Editors now report mouse click events + +API changes: +* Rename TerminalLocation row/column fields to avoid commonplace name + clashes; rename row/column to locationRow/locationColumn (fixes #96) + +Bug fixes: +* Core: make cropToContext also crop extents (fixes #101) +* viewport: if the sub-widget is not rendered, also cull all extents and + cursor locations + +Documentation changes: +* User Guide updates: minor fixes, updates to content on custom widgets, + wide character support, and examples (thanks skapazzo@inventati.org, + Kevin Quick) + +0.14 +---- + +This release added support for wide characters. In particular, wide +characters can now be entered into the text editor widget and used in +'str' and 'txt' widgets. + +0.13 +---- + +API changes: + * Mouse mode is no longer enabled by default. + * customMain's event channel parameter is now optional + * FocusRing now provides a Functor instance (thanks Ian Jeffries) + +0.12 +---- + +This release primarily adds support for mouse interaction. For details, +see the Mouse Support section of the User Guide. This release also +includes breaking API changes for the App type. Here's a migration +guide: + + * Event handlers now take "BrickEvent n e" instead of "e", where "e" + was the custom event type used before this change. To recover your + own custom events, pattern-match on "AppEvent"; to recover Vty input + events, pattern-match on "VtyEvent". + * appLiftVtyEvent went away and can just be removed from your App + record constructor. + * If you aren't using the custom event type or were just using Vty's + "Event" type as your App's event type, you can set your event type to + just "e" because you'll now be able to get Vty events regardless of + whether you use a custom event type. + +API changes: + * Added the Widget combinator "clickable" to indicate that a widget + should generate mouse click events + * Added the Extent data type and the "reportExtent" widget combinator + to report the positions and sizes of widgets + * Rendering "Result" values now include reported extents and update + their offsets (adds "extents" field and "extentsL" lens) + * Added "lookupExtent", "findClickedExtents", and "clickedExtent" in + EventM to find extents and check them for mouse clicks + * Removed appLiftVtyEvent. Instead of wrapping Vty's events in your own + type, you now get a "BrickEvent" that always contains Vty events but + has the ability to embed *your* custom events. See the User Guide for + details. + * Added demo program MouseDemo.hs + * Added demo program ProgressBarDemo.hs (thanks Kevin Quick) + * Added mapAttrname, mapAttrNames, and overrideAttr functions (thanks + Kevin Quick) + * Make handleEventLensed polymorphic over event type to allow use with + custom events (thanks Kevin Quick) + * Added Ord constraint to some library startup functions + +Bug fixes: + * Added Show instance for Editor, List (fixes #63) + +Documentation changes: + * Updated documentation to use new "resource name" terminology to + reduce confusion and better explain the purpose of names. + * Updated user guide with sections on mouse support, the rendering + cache, resource names, paste mode, and extents + +Package changes: + * Depend on Vty 5.11.3 to get mouse mode support + +0.11 +---- + +API changes: + * Added getVtyHandle in EventM for obtaining the current Vty context. + It returns Nothing when calling the appStartEvent handler but after + that a context is always available. + +0.10 +---- + +New features: + * Added a rendering cache. To use the rendering cache, use the 'cached' + widget combinator. This causes drawings of the specified widget to + re-use a cached rendering until the rendering cache is invalidated + with 'invalidateCacheEntry' or 'invalidateCache'. This change also + includes programs/CacheDemo.hs. This change introduced an Ord + constraint on the name type variable 'n'. + * Added setTop and setLeft for setting viewport offsets directly in + EventM. + * Dialog event handlers now support left and right arrow keys (thanks + Grégoire Charvet) + +Library changes: + * On resizes brick now draws the application twice before handling the + resize event. This change makes it possible for event handlers to + get the latest viewport states on a resize rather than getting the + most recent (but stale) versions as before, at the cost of a second + redraw. + +Bug fixes: + * We now use the most recent rendering state when setting up event handler + viewport data. This mostly won't matter to anyone except in cases + where a viewport name was expected to be in the viewport map but + wasn't due to using stale rendering state to set up EventM. + +0.9 +--- + +Package changes: + * Depend on text-zipper 0.7.1 + +API changes: + * The editor widget state value is now polymorphic over the type of + "string" value that can be edited, so you can now create editors over + Text values as well as Strings. This is a breaking change but it only + requires the addition of the string type variable to any uses of + Editor. (thanks Jason Dagit and Getty Ritter) + * Added some missing Eq and Show instances (thanks Grégoire Charvet) + +New features: + * The editor now binds Control-U to delete to beginning of line (thanks + Hans-Peter Deifel) + +Bug fixes: + * List: avoid runtime exception by ensuring item height is always at + least 1 + +0.8 +--- + +API changes: + * Center: added layer-friendly centering functions centerLayer, + hCenterLayer, and vCenterLayer. + +Functionality changes: + * Dialog now uses new layer-friendly centering functions. This makes it + possible to overlay a Dialog on top of your UI when you use a Dialog + rendering as a separate layer. + * Updated the LayerDemo to demonstrate a centered layer. + * The renderer now uses a default Vty Picture background + of spaces with the default attribute, rather than using + ClearBackground (the Vty default). This is to compensate for an + unexpected attribute behavior in Vty when ClearBackgrounds (see + https://github.com/coreyoconnor/vty/issues/95) + +0.7 +--- + +NOTE: this release includes many API changes. Please see the "Widget +Names" section of the Brick User Guide for details on the fundamentals! + +API changes: + * The "Name" type was removed. In its place we now have a name type + variable ("n") attached to many types (including EventM, + CursorLocation, App, Editor, List, and FocusRing). This change makes + it possible to: + * Avoid runtime errors due to name typos + * Achieve compile-time guarantees about name matching and usage + * Force widget functions to be name-agnostic by being polymorphic + in their name type + * Clean up focus handling by making it possible to pattern-match + on cursor location names + * The EditDemo demonstration program was updated to use a FocusRing. + * Added the "Named" type class to Brick.Widgets.Core for types that + store names. This type class is used to streamline the Focus + interface; see Brick.Focus.withFocusRing and EditDemo.hs. + * The List and Editor types are now parameterized on names. + * The List widget is now focus-aware; its rendering function now takes + a boolean indicating whether it should be rendered with focus. The + List uses the following attributes now: + * When not focused, the cursor is rendered with listSelectedAttr. + * When focused, the cursor is rendered with listSelectedFocusedAttr. + * The Editor widget is now focus-aware; its rendering function now + takes a boolean indicating whether it should be rendered with focus. + The Editor uses the following attributes now: + * When not focused, the widget is rendered with editAttr. + * When focused, the widget is rendered with editFocusedAttr. + * The Dialog's name constructor parameter and lens were removed. + * The 'viewport' function was modified to raise a runtime exception if + the widget name it receives is used more than once during the + rendering of a single frame. + +Miscellaneous: + * Many modules now use conditional imports to silence redundancy + warnings on GHCs with newer Preludes (e.g. including Monoid, + Foldable, Traversable, Applicative, etc.) + +0.6.4 +----- + +Bug fixes: + * Add missing Functor instance for Next type (thanks Markus Hauck) + +0.6.3 +----- + +Bug fixes: + * List: the list now properly renders when the available height is not + a multiple of the item height. Previously the list size would + decrease relative to the available height. Now the list renders + enough items to fill the space even if the top-most or bottom-most + item is partially visible, which is the expected behavior. + +0.6.2 +----- + +Bug fixes: + * Editor: the 'editor' initial content parameter is now correctly split + on newlines to ensure that the underlying editor zipper is + initialized properly. (fixes #56; thanks @listx) + +0.6.1 +----- + +Package changes: + * Added lower bound for microlens >= 0.3.0.0 to fix build failure due + to Field1 not being defined (thanks Markus Hauck) + +Documentation changes: + * Updated user guide and README to link to and mention microlens + instead of lens + +Misc: + * Fixed a qualified import in the List demo to avoid ambiguity (thanks + Alan Gilbert) + +0.6 +--- + +API changes: + * Brick now uses the microlens family of packages instead of lens. This + version of brick also depends on vty 5.5.0, which was modified to use + microlens instead of lens. This change shouldn't impact functionality + but will greatly reduce build times. + +0.5.1 +----- + +Bug fixes: + * Fix negative cropping in hCenter, vCenter, and cropResultToContext + (fixes #52) + * Remove unnecessary Eq constraint from listReplace (fixes #48; thanks + sifmelcara) + * Mention Google Group in README + +0.5 +--- + +Functionality changes: + * Markup: make markup support multi-line strings (fixes #41) + * brick-edit-demo: support shift-tab to switch editors + * Core: improve box layout algorithm (when rendering boxes, track + remaining space while rendering high-priority children to use + successively more constrained primary dimensions) + * Core: make fixed padding take precedence over padded widgets (fixes #42) + Prior to this commit, padding a widget meant that if there was room + after rendering the widget, the specified amount of padding would be + added. This meant that under tight layout constraints padding would + disappear before a padded widget would. This is often a desirable + outcome but it also led to unexpected behavior when adding padding + to a widget that grows greedily: fixed padding would never show up + because it was placed in a box adjacent to the widget in question, + and boxes always render greedy children before fixed ones. As a + result fixed padding would disappear under these conditions. Instead, + in the case of fixed padding, since we often intend to *guarantee* + that padding is present, all of the padding combinators have been + modified so that when the padded widget is rendered with fixed + padding in the amount V, the widget is given V fewer rows/columns + when it is rendered so that the padding always has room. + +0.4.1 +----- + +Bug fixes: +* Fixed a bug in the 'visible' combinator: If the size of the visibility + request was larger than the available space, then the rendering of a + viewport was toggling between two states, one with aligning on the + end of the visibility request, and another one aligning on the start. + This commit fixes it so that a visibility request is always aligned + on the start if not enough space is available. (thanks Thomas Strobel + ) + +Behavior changes: +* Honor multiple 'visible' markers in a single viewport with preference + on the innermost request (thanks Thomas Strobel ) + +0.4 +--- + +API changes: +* Added Brick.Widgets.Core.unsafeLookupViewport to make certain kinds + of custom widget implementations easier when viewport states are needed + (thanks Markus Hauck ) +* List: added listClear and listReverse functions (thanks Markus Hauck) +* List: Derive instances for Functor, Foldable, Traversable (thanks + Markus Hauck) + +Documentation changes: +* Hyperlink "Data.Text.Markup" inside Brick.Markup haddock (thanks + Markus Hauck) +* Fix typo in 'Attribute Management' section of user guide (thanks + Markus Hauck) + +0.3.1 +----- + +Bug fixes: +* EventM newtype again instances MonadIO (thanks Andrew Rademacher) + +0.3 +--- + +API changes: +* Made EventM a newtype instead of a type alias +* List: listReplace now takes the new selected index and no longer does +element diffing + +Package changes: +* Removed the dependency on the Diff package + +Misc: +* Applied some hlint hints (thanks Markus Hauck ) +* Fixed a typo in the README (thanks Markus Hauck ) +* Improved the renderList documentation (thanks Profpatsch ) +* Types: added an explicit import of Applicative for older GHCs + +0.2.3 +----- + +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 cropping in vty; now the behavior is + handled sanely (fixes #22; reported by Hans-Peter Deifel) + +0.2.2 +----- + +Demo changes: +* Improved the list demo by using characters instead of integers in the + demo list and cleaned up item-adding code (thanks Jøhannes Lippmann + ) + +0.2.1 +----- + +Bug fixes: +* List: + * Fixed size policy of lists so that rather than being Fixed/Fixed, + they are Greedy/Greedy. This resolves issues that arise when the box + layout widget renders a list widget alongside a Fixed/Fixed one. + (Closes issue #17, thanks Karl Voelker) +* Scrolling: + * vScrollPage actually scrolls vertically now rather than horizontally + (Thanks Hans-Peter Deifel ) + +0.2 +--- + +API changes: +* Added top-level `Brick` module that re-exports the most important + modules in the library. +* List: + * Now instead of passing the item-drawing function to the `list` state + constructor, it is passed to `renderList` + * `renderList` now takes the row height of the list's item widgets. + The list item-drawing function must respect this in order for + scrolling to work properly. This change made it possible to optimize + the list so that it only draws widgets visible in the viewport + rather than rendering all of the list's items (even the ones + off-screen). But to do this we must be able to tell in advance + how high each one is, so we require this parameter. In addition + this change means that lists no longer support items of different + heights. + * The list now uses Data.Vector instead of [a] to store items; this + permits efficient slicing so we can do the optimized rendering + described above. +* The `HandleEvent` type class `handleEvent` method now runs in + `EventM`. This permits event-handling code implemented in terms of + `HandleEvent` to do get access to viewport state and to run IO code, + making it just as powerful as code in the top-level `EventM` handler. +* Many types were moved from `Brick.Widgets.Core` and `Brick.Main` to + `Brick.Types`, making the former module merely a home for `Widget` + constructors and combinators. +* The `IsString` instance for `Widget` was removed; this might be + reinstated later, but this package provides enough `IsString` + instances that things can get confusing. +* `EventM` is now reader monad over the most recent rendering pass's + viewport state, in addition to being a state monad over viewport + requests for the renderer. Added the `lookupViewport` function to + provide access to the most recent viewport state. Exported the + `Viewport` type and lenses. +* Now that `handleEvent` is now an `EventM` action, composition with + `continue` et al got a little messier when using lenses to + update the application state. To help with this, there is now + `handleEventLensed`. + +Bugfixes: +* Lists now perform well with 10 items or a million (see above; fixes + #7, thanks Simon Michael) +* Added more haddock notes to `Brick.Widgets.Core` about growth + policies. +* Forced evaluation of render states to address a space leak in the + renderer (fixes #14, thanks Sebastian Reuße ) +* str: only reference string content that can be shown (eliminates a + space leak, fixes #14, thanks Sebastian Reuße ) + +Misc: +* Added a makefile for the user guide. +* List: added support for Home and End keys (thanks Simon Michael) +* Viewports: when rendering viewports, scroll requests from `EventM` are + processed before visibility requests from the rendering process; this + reverses this previous order of operations but permits user-supplied + event handlers to reset viewports when desired. + +Package changes: +* Added `deepseq` dependency + +0.1 +--- + Initial release diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Jonathan Daugherty. +Copyright (c) 2015-2025, Jonathan Daugherty. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,108 +1,211 @@ -brick ------ - -[![Build Status](https://travis-ci.org/jtdaugherty/brick.png)](https://travis-ci.org/jtdaugherty/brick) +![](logo/brick-final-clearbg-with-text.svg) -`brick` is a terminal user interface programming -library written in Haskell, in the style of -[gloss](http://hackage.haskell.org/package/gloss). This means you write -a function that describes how your user interface should look, but the -library takes care of a lot of the book-keeping that so commonly goes -into writing such programs. +`brick` is a Haskell terminal user interface (TUI) programming toolkit. +To use it, you write a pure function that describes how your user +interface should be drawn based on your current application state and +you provide a state transformation function to handle events. `brick` exposes a declarative API. Unlike most GUI toolkits which -require you to write a long and tedious sequence of "create a widget, -now bind an event handler", `brick` just requires you to describe -your interface -- even the bits that are stateful -- using a set of -declarative combinators. Then you provide a function to transform your -own application state when input (or other kinds of) events arrive. +require you to write a long and tedious sequence of widget creations +and layout setup, `brick` just requires you to describe your interface +using a set of declarative layout combinators. Event-handling is done by +pattern-matching on incoming events and updating your application state. -Under the hood, this library builds upon [vty](http://hackage.haskell.org/package/vty). +Under the hood, this library builds upon +[vty](http://hackage.haskell.org/package/vty), so some knowledge of Vty +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. -This library deprecates [vty-ui](https://github.com/jtdaugherty/vty-ui). +Example +------- -Feature Overview ----------------- +Here's an example interface (see `programs/ReadmeDemo.hs`): -`brick` comes with a bunch of widget types to get you started: +``` +joinBorders $ +withBorderStyle unicode $ +borderWithLabel (str "Hello!") $ +(center (str "Left") <+> vBorder <+> center (str "Right")) +``` - * Vertical and horizontal box layout widgets - * Basic single- and multi-line text editor widgets - * List widget - * Progress bar widget - * Simple dialog box widget - * Border-drawing widgets (put borders around or in between things) - * Generic scrollable viewports - * Extensible widget-building API - * (And many more general-purpose layout control combinators) +Result: -In addition, some of `brick`'s more powerful features may not be obvious -right away: +``` +┌─────────Hello!─────────┐ +│ │ │ +│ │ │ +│ Left │ Right │ +│ │ │ +│ │ │ +└───────────┴────────────┘ +``` - * All widgets can be arranged in predictable layouts so you don't have - to worry about terminal resizes. - * Most widgets can be made scrollable *for free*. - * Attribute management is flexible and can be customized at runtime on - a per-widget basis. +Featured Projects +----------------- -`brick` exports [lens](http://github.com/ekmett/lens) and non-`lens` -interfaces for most things, so you can get the full power of `lens` if -you want it or use plain Haskell if you don't. If a `brick` library -function named `thing` has a `lens` version, the `lens` version is named -`thingL`. +To get an idea of what some people have done with `brick`, check out +these projects. If you have made something and would like me to include +it, get in touch! +| Project | Description | +| ------- | ----------- | +| [`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 | +| [`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 | +| [`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 | +| [`purebred`](https://github.com/purebred-mua/purebred) | A mail user agent | +| [`sandwich`](https://codedownio.github.io/sandwich/) | A test framework with a TUI interface | +| [`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 | +| [`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 | +| [`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 | + +These additional packages also extend `brick`: + +| 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 --------------- -TLDR: +Check out the many demo programs to get a feel for different aspects of +the library: ``` -$ cabal sandbox init -$ cabal install -j -f demos -$ .cabal-sandbox/bin/brick-???-demo +$ cabal new-build -f demos +$ find dist-newstyle -type f -name \*-demo ``` -To get started, see the [first few sections of the brick -user guide](docs/guide.rst). +To get started, see the [user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst). Documentation ------------- -Your documentation options, in recommended order, are: +Documentation for `brick` comes in a variety of forms: -* [FAQ](https://github.com/jtdaugherty/brick/blob/master/FAQ.md) -* [The brick user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst) -* Haddock (all modules) +* [The official brick user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst) +* [Haddock documentation](https://hackage.haskell.org/package/brick) * [Demo programs](https://github.com/jtdaugherty/brick/blob/master/programs) +* [FAQ](https://github.com/jtdaugherty/brick/blob/master/FAQ.md) +Feature Overview +---------------- + +`brick` comes with a bunch of batteries included: + + * Vertical and horizontal box layout widgets + * Basic single- and multi-line text editor widgets + * List and table widgets + * Progress bar widget + * Simple dialog box widget + * 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 + * User-customizable attribute themes + * Type-safe, validated input form API (see the `Brick.Forms` module) + * A filesystem browser for file and directory selection + * Borders can be configured to automatically connect! + +Brick Discussion +---------------- + +There are two forums for discussing brick-related things: + +1. The [Discussions page](https://github.com/jtdaugherty/brick/discussions) on the github repo, and +1. The `brick-users` Google Group / e-mail list. You can subscribe + [here](https://groups.google.com/group/brick-users). + Status ------ -`brick` is young and may be missing some essential features. There are -some places were I have deliberately chosen to worry about performance -later for the sake of spending more time on the design (and to wait on -performance issues to arise first). `brick` exports an extension API -that makes it possible to make your own packages and widgets. If you -use that, you'll also be helping to test whether the exported interface -is usable and complete! +There are some places were I have deliberately chosen to worry about +performance later for the sake of spending more time on the design +(and to wait on performance issues to arise first). `brick` is also +something of an experimental project of mine and some aspects of the +design involve trade-offs that might not be right for your application. +Brick is not intended to be all things to all people; rather, I want it +to provide a good foundation for building complex terminal interfaces +in a declarative style to take away specific headaches of building, +modifying, and working with such interfaces, all while seeing how far we +can get with a pure function to specify the interface. -The development of this library has revealed some bugs in `vty`, and -I've tried to report those as I go. If they haven't been resolved, -you'll see them arise when using `brick`. +`brick` exports an extension API that makes it possible to make your own +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. Even better, the output of `cabal freeze` would probably be - helpful in making the problem reproducible. + emulator, `brick`, `ghc`, `vty`, and Vty platform packages will be + the most important ones. - Clearly describe the behavior you expected ... - - ... and include a mininal demonstration program that exhibits the + - ... and include a minimal demonstration program that exhibits the behavior you actually observed. Contributing @@ -111,10 +214,22 @@ 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. - 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. - - If you make changes, try to make them consistent with the syntactic - conventions I've used in the codebase. - - Please provide Haddock and/or user guide documentation for any - changes you make. + - Please make changes consistent with the conventions I've used in the + codebase. + - Please adjust or provide Haddock and/or user guide documentation + relevant to any changes you make. + - 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 + appropriate version change. diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,16 +1,17 @@ name: brick -version: 0.2.3 +version: 2.12 synopsis: A declarative terminal user interface library description: - Write terminal applications painlessly with 'brick'! You write an - event handler and a drawing function and the library does the rest. + Write terminal user interfaces (TUIs) painlessly with 'brick'! You + write an event handler and a drawing function and the library does the + rest. . . > module Main where > > import Brick > - > ui :: Widget + > ui :: Widget () > ui = str "Hello, world!" > > main :: IO () @@ -31,20 +32,34 @@ license-file: LICENSE author: Jonathan Daugherty maintainer: Jonathan Daugherty -copyright: (c) Jonathan Daugherty 2015 +copyright: (c) Jonathan Daugherty 2015-2025 category: Graphics build-type: Simple -cabal-version: >=1.10 +cabal-version: 1.18 Homepage: https://github.com/jtdaugherty/brick/ Bug-reports: https://github.com/jtdaugherty/brick/issues +tested-with: GHC == 8.2.2 + || == 8.4.4 + || == 8.6.5 + || == 8.8.4 + || == 8.10.7 + || == 9.0.2 + || == 9.2.8 + || == 9.4.8 + || == 9.6.7 + || == 9.8.4 + || == 9.10.3 + || == 9.12.2 -data-files: README.md, +extra-doc-files: README.md, docs/guide.rst, - CHANGELOG.md + docs/snake-demo.gif, + CHANGELOG.md, + 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 @@ -52,14 +67,26 @@ library default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind -O3 + 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 + Brick.Keybindings + Brick.Keybindings.KeyConfig + Brick.Keybindings.KeyEvents + Brick.Keybindings.KeyDispatcher + Brick.Keybindings.Normalize + Brick.Keybindings.Parse + Brick.Keybindings.Pretty Brick.Focus + Brick.Forms Brick.Main - Brick.Markup + Brick.Themes Brick.Types Brick.Util Brick.Widgets.Border @@ -68,207 +95,466 @@ Brick.Widgets.Core Brick.Widgets.Dialog Brick.Widgets.Edit + Brick.Widgets.FileBrowser Brick.Widgets.List Brick.Widgets.ProgressBar - Data.Text.Markup + 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 <= 5, - vty >= 5.3.1, - transformers, - data-default, - Diff, - containers, - lens, + 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 && < 0.6, + microlens-th, + microlens-mtl, + mtl, + config-ini, vector, - contravariant, + stm >= 2.4.3, text, - text-zipper >= 0.2.1, + text-zipper >= 0.13, template-haskell, - deepseq >= 1.3 && < 1.5 + deepseq >= 1.3 && < 1.6, + unix-compat, + bytestring, + word-wrap >= 0.2, + unordered-containers, + hashable, + time +executable brick-custom-keybinding-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: CustomKeybindingDemo.hs + build-depends: base, + brick, + text, + vty, + containers, + microlens, + microlens-mtl, + microlens-th + +executable brick-table-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: TableDemo.hs + build-depends: base, + brick + +executable brick-tail-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: TailDemo.hs + build-depends: base, + brick, + text, + vty, + random, + microlens-th, + microlens-mtl + +executable brick-readme-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: ReadmeDemo.hs + build-depends: base, + brick + +executable brick-file-browser-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: FileBrowserDemo.hs + build-depends: base, + vty, + brick, + text, + mtl + +executable brick-form-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: FormDemo.hs + build-depends: base, + brick, + text, + microlens, + microlens-th, + vty-crossplatform, + vty + +executable brick-text-wrap-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: TextWrapDemo.hs + build-depends: base, + brick, + word-wrap + +executable brick-cache-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: CacheDemo.hs + build-depends: base, + brick, + vty, + mtl + executable brick-visibility-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: VisibilityDemo.hs build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty, + microlens >= 0.3.0.0, + microlens-th, + microlens-mtl +executable brick-viewport-scrollbars-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + default-extensions: CPP + main-is: ViewportScrollbarsDemo.hs + build-depends: base, + brick, + vty, + vty-crossplatform, + microlens-mtl, + microlens-th + executable brick-viewport-scroll-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 + default-extensions: CPP main-is: ViewportScrollDemo.hs build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty executable brick-dialog-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: DialogDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty +executable brick-mouse-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: MouseDemo.hs + build-depends: base, + brick, + vty, + microlens >= 0.3.0.0, + microlens-th, + microlens-mtl, + mtl + executable brick-layer-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: LayerDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty, + microlens >= 0.3.0.0, + microlens-th, + microlens-mtl executable brick-suspend-resume-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: SuspendAndResumeDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty, + microlens >= 0.3.0.0, + microlens-th +executable brick-cropping-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: CroppingDemo.hs + build-depends: base, + brick, + vty + executable brick-padding-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: PaddingDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty +executable brick-theme-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: ThemeDemo.hs + build-depends: base, + brick, + vty, + mtl + executable brick-attr-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: AttrDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty -executable brick-markup-demo +executable brick-tabular-list-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 - main-is: MarkupDemo.hs - build-depends: base <= 5, + main-is: TabularListDemo.hs + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty, + microlens >= 0.3.0.0, + microlens-mtl, + microlens-th, + vector executable brick-list-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: ListDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens, + vty, + microlens >= 0.3.0.0, + microlens-mtl, + mtl, vector +executable brick-list-vi-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: ListViDemo.hs + build-depends: base, + brick, + vty, + 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 hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: CustomEventDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty, + microlens >= 0.3.0.0, + microlens-th, + microlens-mtl +executable brick-fill-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: FillDemo.hs + build-depends: base, + brick + executable brick-hello-world-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: HelloWorldDemo.hs - build-depends: base <= 5, - brick, - vty >= 5.3.1, - data-default, - text, - lens + build-depends: base, + brick executable brick-edit-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: EditDemo.hs - build-depends: base <= 5, + build-depends: base, brick, - vty >= 5.3.1, - data-default, - text, - lens + vty, + microlens >= 0.3.0.0, + microlens-th, + microlens-mtl +executable brick-editor-line-numbers-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: EditorLineNumbersDemo.hs + build-depends: base, + brick, + vty, + microlens >= 0.3.0.0, + microlens-th, + microlens-mtl + executable brick-border-demo if !flag(demos) Buildable: False hs-source-dirs: programs - ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 + default-extensions: CPP default-language: Haskell2010 main-is: BorderDemo.hs + build-depends: base, + brick, + vty, + text + +executable brick-dynamic-border-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-extensions: CPP + 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 >= 5.3.1, - data-default, - text, - lens + vty, + microlens-mtl, + microlens-th + +test-suite brick-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + ghc-options: -Wall -Wcompat -Wno-orphans -O2 + default-language: Haskell2010 + main-is: Main.hs + other-modules: List Render + build-depends: base <=5, + brick, + containers, + microlens, + vector, + vty, + vty-crossplatform, + QuickCheck diff --git a/docs/guide.rst b/docs/guide.rst --- a/docs/guide.rst +++ b/docs/guide.rst @@ -11,867 +11,2147 @@ and as direct as possible. ``brick`` builds on `vty`_; `vty` provides the terminal input and output interface and drawing primitives, while ``brick`` builds on those to provide a high-level application -abstraction and combinators for expressing user interface layouts. - -This documentation is intended to provide a high-level overview of -the library's design along with guidance for using it, but details on -specific functions can be found in the Haddock documentation. - -The process of writing an application using ``brick`` entails writing -two important functions: - -- A *drawing function* that turns your application state into a - specification of how your interface should look, and -- An *event handler* that takes your application state and an input - event and decides whether to change the state or quit the program. - -We write drawing functions in ``brick`` using an extensive set of -primitives and combinators to place text on the screen, set its -attributes (e.g. foreground color), and express layout constraints (e.g. -padding, centering, box layouts, scrolling viewports, etc.). - -These functions get packaged into a structure that we hand off to the -``brick`` library's main event loop. We'll cover that in detail in `The -App Type`_. - -Installation ------------- - -``brick`` can be installed in the "usual way," either by installing -the latest `Hackage`_ release or by cloning the GitHub repository and -building locally. - -To install from Hackage:: - - $ cabal update - $ cabal install brick - -To clone and build locally:: - - $ git clone https://github.com/jtdaugherty/brick.git - $ cd brick - $ cabal sandbox init - $ cabal install -j - -Building the Demonstration Programs ------------------------------------ - -``brick`` includes a large collection of feature-specific demonstration -programs. These programs are not built by default but can be built by -passing the ``demos`` flag to `cabal install`, e.g.:: - - $ cabal install brick -f demos - -Conventions -=========== - -``brick`` has some API conventions worth knowing about as you read this -documentation and as you explore the library source and write your own -programs. - -- Use of `lens`_: ``brick`` uses ``lens`` functions internally and also - exposes lenses for many types in the library. However, if you prefer - not to use the ``lens`` interface in your program, all ``lens`` - interfaces have non-`lens` equivalents exported by the same module. In - general, the "``L``" suffix on something tells you it is a ``lens``; - the name without the "``L``" suffix is the non-`lens` version. You can - get by without using ``brick``'s ``lens`` interface but your life will - probably be much more pleasant once your application state becomes - sufficiently complex if you use lenses to modify it (see - `appHandleEvent: Handling Events`_). -- Attribute names: some modules export attribute names (see `How - Attributes Work`_) associated with user interface elements. These tend - to end in an "``Attr``" suffix (e.g. ``borderAttr``). In addition, - hierarchical relationships between attributes are documented in - Haddock documentation. -- Use of qualified names: in this document, where sensible, I will use - fully-qualified names whenever I mention something for the first time - or whenever I use something that is not part of ``brick``. Use of - names in this way is not intended to produce executable examples, but - rather to guide you in writing your ``import`` statements. - -The App Type -============ - -To use the library we must provide it with a value of type -``Brick.Main.App``. This type is a record type whose fields perform -various functions: - -.. code:: haskell - - data App s e = - App { appDraw :: s -> [Widget] - , appChooseCursor :: s -> [CursorLocation] -> Maybe CursorLocation - , appHandleEvent :: s -> e -> EventM (Next s) - , appStartEvent :: s -> EventM s - , appAttrMap :: s -> AttrMap - , appLiftVtyEvent :: Event -> e - } - -The ``App`` type is polymorphic over two types: your application state -type ``s`` and event type ``e``. - -The application state type is the type of data that will evolve over the -course of the application's execution; we will provide the library with -its starting value and event handling will transform it as the program -executes. - -The event type is the type of events that your event handler -(``appHandleEvent``) will handle. The underlying ``vty`` library -provides ``Graphics.Vty.Event`` and this forms the basis of all events -we will handle with ``brick`` applications. The -``Brick.Main.defaultMain`` function expects an ``App s Event`` since -this is a common case. - -However, we often need to extend our notion of events beyond those -originating from the keyboard. Imagine an application with multiple -threads and network or disk I/O. Such an application will need to have -its own internal events to pass to the event handler as (for example) -network data arrives. To accommodate this we allow an ``App`` to use an -event type of your own design, so long as it provides a constructor for -``vty``'s ``Event`` type (``appLiftVtyEvent``). For more details, see -`Using Your Own Event Type`_. - -The various fields of ``App`` will be described in the sections below. - -To run an ``App``, we pass it to ``Brick.Main.defaultMain`` or -``Brick.Main.customMain`` along with an initial application state value. - -appDraw: Drawing an Interface ------------------------------ - -The value of ``appDraw`` is a function that turns the current -application state into a list of *layers* of type ``Widget``, listed -topmost first, that will make up the interface. Each ``Widget`` gets -turned into a ``vty`` layer and the resulting layers are drawn to the -terminal. - -The ``Widget`` type is the type of *drawing instructions*. The body of -your drawing function will use one or more drawing functions to build or -transform ``Widget`` values to describe your interface. These -instructions will then be executed with respect to three things: - -- The size of the terminal: the size of the terminal determines how many - ``Widget`` values behave. For example, fixed-size ``Widget`` values - such as text strings behave the same under all conditions (and get - cropped if the terminal is too small) but layout combinators such as - ``Brick.Widgets.Core.vBox`` or ``Brick.Widgets.Center.center`` use the - size of the terminal to determine how to lay other widgets out. See - `How Widgets and Rendering Work`_. -- The application's attribute map (``appAttrMap``): drawing functions - requesting the use of attributes cause the attribute map to be - consulted. See `How Attributes Work`_. -- The state of scrollable viewports: the state of any scrollable - viewports on the *previous* drawing will be considered. For more - details, see `Viewports`_. - -The ``appDraw`` function is called when the event loop begins to draw -the application as it initially appears. It is also called right after -an event is processed by ``appHandleEvent``. Even though the function -returns a specification of how to draw the entire screen, the underlying -``vty`` library goes to some trouble to efficiently update only the -parts of the screen that have changed so you don't need to worry about -this. - -Where do I find drawing functions? -********************************** - -The most important module providing drawing functions is -``Brick.Widgets.Core``. Beyond that, any module in the ``Brick.Widgets`` -namespace provides specific kinds of functionality. - -appHandleEvent: Handling Events -------------------------------- - -The value of ``appHandleEvent`` is a function that decides how to modify -the application state as a result of an event. It also decides whether -to continue program execution. The function takes the current -application state and the event and returns the *next application -state*: - -.. code:: haskell - - appHandleEvent :: s -> e -> EventM (Next s) - -The ``EventM`` monad is the event-handling monad. This monad is a -transformer around ``IO``, so you are free to do I/O in this monad by -using ``liftIO``. Beyond I/O, this monad is just used to make scrolling -requests to the renderer (see `Viewports`_). Keep in mind that time -spent blocking in your event handler is time during which your UI is -unresponsive, so consider this when deciding whether to have background -threads do work instead of inlining the work in the event handler. - -The ``Next s`` value describes what should happen after the event -handler is finished. We have three choices: - -* ``Brick.Main.continue s``: continue executing the event loop with the - specified application state ``s`` as the next value. Commonly this is - where you'd modify the state based on the event and return it. -* ``Brick.Main.halt s``: halt the event loop and return the final - application state value ``s``. This state value is returned to the - caller of ``defaultMain`` or ``customMain`` where it can be used prior - to finally exiting ``main``. -* ``Brick.Main.suspendAndResume act``: suspend the ``brick`` event loop - and execute the specified ``IO`` action ``act``. The action ``act`` - must be of type ``IO s``, so when it executes it must return the next - application state. When ``suspendAndResume`` is used, the ``brick`` - event loop is shut down and the terminal state is restored to its - state when the ``brick`` event loop began execution. When it finishes - executing, the event loop will be resumed using the returned state - value. This is useful for situations where your program needs to - suspend your interface and execute some other program that needs to - gain control of the terminal (such as an external editor). - -The HandleEvent Type Class -************************** - -Event handlers are responsible for transforming the application state. -While you can use ordinary methods to do this such as pattern matching -and pure function calls, some widget state types such as the ones -provided by the ``Brick.Widgets.List`` and ``Brick.Widgets.Edit`` -modules support another interface: the ``Brick.Types.HandleEvent`` type -class. - -The ``HandleEvent`` type class has only one method: - -.. code:: haskell - - handleEvent :: Event -> a -> EventM a - -Instances of ``HandleEvent`` provide reasonable default behavior for -handling input events; for example, arrow keys change the ``List`` -selection and input keys modify the text in ``Editor`` states. - -Since ``handleEvent`` runs in ``EventM``, event handlers -written this way have access to rendering viewport states via -``Brick.Main.lookupViewport`` and the ``IO`` monad via ``liftIO``. - -To use ``handleEvent`` in your program, invoke it on the relevant piece -of state in your event handler, e.g., - -.. code:: haskell - - myEvent :: s -> e -> EventM (Next s) - myEvent s e = continue =<< handleEvent e s - -This pattern works fine when your application state instances -``HandleEvent``, but it can become unpleasant if the value on which -you want to invoke ``handleEvent`` is embedded deeply within your -application state. If you have chosen to generate lenses for your -application state fields, you can use the convenience function -``handleEventLensed`` by specifying your state, a lens, and the event: - -.. code:: haskell - - myEvent :: s -> e -> EventM (Next s) - myEvent s e = continue =<< handleEventLensed s someLens e - -Compare that with the more verbose explicit version: - -.. code:: haskell - - myEvent :: s -> e -> EventM (Next s) - myEvent s e = do - newVal <- handleEvent e (s^.someLens) - continue $ s & someLens .~ newVal - -Using Your Own Event Type -************************* - -Since we often need to communicate application-specific events -beyond input events to the event handler, the ``App`` type is -polymorphic over the event type we want to handle. If we use -``Brick.Main.defaultMain`` to run our ``App``, we have to use -``Graphics.Vty.Event`` as our event type. But if our application has -other event-handling needs, we need to use our own event type. - -To do this, we first define an event type: - -.. code:: haskell - - data CustomEvent = - VtyEvent Graphics.Vty.Event - | CustomEvent1 - | CustomEvent2 - -Our custom event type *must* provide a constructor capable of taking -a ``Graphics.Vty.Event`` value. This allows the ``brick`` event loop -to send us ``vty`` events in the midst of our custom ones. To allow -``brick`` to do this, we provide this constructor as the value of -``appLiftVtyEvent``. This way, ``brick`` can wrap a ``vty`` event using -our custom event type and then pass it to our event handler (which takes -``CustomEvent`` values). In this case we'd set ``appLiftVtyEvent = -VtyEvent``. - -Once we have set ``appLiftVtyEvent`` in this way, we also need to set up -a mechanism for getting our custom events into the ``brick`` event loop -from other threads. To do this we use a ``Control.Concurrent.Chan`` and -call ``Brick.Main.customMain`` instead of ``Brick.Main.defaultMain``: - -.. code:: haskell - - main :: IO () - main = do - eventChan <- Control.Concurrent.newChan - finalState <- customMain (Graphics.Vty.mkVty Data.Default.def) eventChan app initialState - -- Use finalState and exit - -Beyond just the application and its initial state, 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. - -Starting up: appStartEvent -************************** - -When an application starts, it may be desirable to perform some of -the duties typically only possible when an event has arrived, such as -setting up initial scrolling viewport state. Since such actions can only -be performed in ``EventM`` and since we do not want to wait until the -first event arrives to do this work in ``appHandleEvent``, the ``App`` -type provides ``appStartEvent`` function for this purpose: - -.. code:: haskell - - appStartEvent :: s -> EventM s - -This function takes the initial application state and returns it in -``EventM``, possibly changing it and possibly making viewport requests. -For more details, see `Viewports`_. You will probably just want to use -``return`` as the implementation of this function for most applications. - -appChooseCursor: Placing the Cursor ------------------------------------ - -The rendering process for a ``Widget`` may return information about -where that widget would like to place the cursor. For example, a text -editor will need to report a cursor position. However, since a -``Widget`` may be a composite of many such cursor-placing widgets, we -have to have a way of choosing which of the reported cursor positions, -if any, is the one we actually want to honor. - -To decide which cursor placement to use, or to decide not to show one at -all, we set the ``App`` type's ``appChooseCursor`` function: - -.. code:: haskell - - appChooseCursor :: s -> [CursorLocation] -> Maybe CursorLocation - -The event loop renders the interface and collects the -``Brick.Types.CursorLocation`` values produced by the rendering process -and passes those, along with the current application state, to this -function. Using your application state (to track which text input box -is "focused," say) you can decide which of the locations to return or -return ``Nothing`` if you do not want to show a cursor. - -We decide which location to show by looking at the ``Brick.Types.Name`` -value contained in the ``cursorLocationName`` field. The ``Name`` -value associated with a cursor location will be the ``Name`` of the -``Widget`` that requested it; this is why constructors for widgets like -``Brick.Widgets.Edit.editor`` require a ``Name`` parameter. The ``Name`` -lets us distinguish between many cursor-placing widgets of the same -type. - -``Brick.Main`` provides various convenience functions to make cursor -selection easy in common cases: - -* ``neverShowCursor``: never show any cursor. -* ``showFirstCursor``: always show the first cursor request given; good - for applications with only one cursor-placing widget. -* ``showCursorNamed``: show the cursor with the specified name or - ``Nothing`` if it is not requested. - -Widgets request cursor placement by using the -``Brick.Widgets.Core.showCursor`` combinator. For example, this widget -places a cursor on the first "``o``" in "``foo``" assocated with the -cursor name "``myCursor``": - -.. code:: haskell - - let w = showCursor (Name "myCursor") (Brick.Types.Location (1, 0)) - (Brick.Widgets.Core.str "foobar") - -appAttrMap: Managing Attributes -------------------------------- - -In ``brick`` we use an *attribute map* to assign attibutes to elements -of the interface. Rather than specifying specific attributes when -drawing a widget (e.g. red-on-black text) we specify an *attribute name* -that is an abstract name for the kind of thing we are drawing, e.g. -"keyword" or "e-mail address." We then provide an attribute map which -maps those attribute names to actual attributes. This approach lets us: - -* Change the attributes at runtime, letting the user change the - attributes of any element of the application arbitrarily without - forcing anyone to build special machinery to make this configurable; -* Write routines to load saved attribute maps from disk; -* Provide modular attribute behavior for third-party components, where - we would not want to have to recompile third-party code just to change - attributes, and where we would not want to have to pass in attribute - arguments to third-party drawing functions. - -This lets us put the attribute mapping for an entire app, regardless of -use of third-party widgets, in one place. - -To create a map we use ``Brick.AttrMap.attrMap``, e.g., - -.. code:: haskell - - App { ... - , appAttrMap = const $ attrMap Graphics.Vty.defAttr [(someAttrName, fg blue)] - } - -To use an attribute map, we specify the ``App`` field ``appAttrMap`` as -the function to return the current attribute map each time rendering -occurs. This function takes the current application state, so you may -choose to store the attribute map in your application state. You may -also choose not to bother with that and to just set ``appAttrMap = const -someMap``. - -To draw a widget using an attribute name in the map, use -``Brick.Widgets.Core.withAttr``. For example, this draws a string with a -``blue`` background: - -.. code:: haskell - - let w = withAttr blueBg $ str "foobar" - blueBg = attrName "blueBg" - myMap = attrMap defAttr [ (blueBg, Brick.Util.bg Graphics.Vty.blue) - ] - -For complete details on how attribute maps and attribute names work, see -the Haddock documentation for the ``Brick.AttrMap`` module. See also -`How Attributes Work`_. - -How Widgets and Rendering Work -============================== - -When ``brick`` renders a ``Widget``, the widget's rendering routine is -evaluated to produce a ``vty`` ``Image`` of the widget. The widget's -rendering routine runs with some information called the *rendering -context* that contains: - -* The size of the area in which to draw things -* The name of the current attribute to use to draw things -* The map of attributes to use to look up attribute names -* The active border style to use when drawing borders - -Available Rendering Area ------------------------- - -The most important element in the rendering context is the rendering -area: This part of the context tells the widget being drawn how many -rows and columns are available for it to consume. When rendering begins, -the widget being rendered (i.e. a layer returned by an ``appDraw`` -function) gets a rendering context whose rendering area is the size of -the terminal. This size information is used to let widgets take up that -space if they so choose. For example, a string "Hello, world!" will -always take up one row and 13 columns, but the string "Hello, world!" -*centered* will always take up one row and *all available columns*. - -How widgets use space when rendered is described in two pieces of -information in each ``Widget``: the widget's horizontal and vertical -growth policies. These fields have type ``Brick.Types.Size`` and can -have the values ``Fixed`` and ``Greedy``. - -A widget advertising a ``Fixed`` size in a given dimension is a widget -that will always consume the same number of rows or columns no -matter how many it is given. Widgets can advertise different -vertical and horizontal growth policies for example, the -``Brick.Widgets.Border.hCenter`` function centers a widget and is -``Greedy`` horizontally and defers to the widget it centers for vertical -growth behavior. - -These size policies govern the box layout algorithm that is at -the heart of every non-trivial drawing specification. When we use -``Brick.Widgets.Core.vBox`` and ``Brick.Widgets.Core.hBox`` to -lay things out (or use their binary synonyms ``<=>`` and ``<+>``, -respectively), the box layout algorithm looks at the growth policies of -the widgets it receives to determine how to allocate the available space -to them. - -For example, imagine that the terminal window is currently 10 rows high -and 50 columns wide. We wish to render the following widget: - -.. code:: haskell - - let w = (str "Hello," <=> str "World!") - -Rendering this to the terminal will result in "Hello," and "World!" -underneath it, with 8 rows unoccupied by anything. But if we wished to -render a vertical border underneath those strings, we would write: - -.. code:: haskell - - let w = (str "Hello," <=> str "World!" <=> vBorder) - -Rendering this to the terminal will result in "Hello," and "World!" -underneath it, with 8 rows remaining occupied by vertical border -characters ("``|``") one column wide. The vertical border widget is -designed to take up however many rows it was given, but rendering the -box layout algorithm has to be careful about rendering such ``Greedy`` -widgets because the won't leave room for anything else. Since the box -widget cannot know the sizes of its sub-widgets until they are rendered, -the ``Fixed`` widgets get rendered and their sizes are used to determine -how much space is left for ``Greedy`` widgets. - -When using widgets it is important to understand their horizontal and -vertical space behavior by knowing their ``Size`` values. Those should -be made clear in the Haddock documentation. - -Limiting Rendering Area ------------------------ - -If you'd like to use a ``Greedy`` widget but want to limit how much -space it consumes, you can turn it into a ``Fixed`` widget by using -one of the *limiting combinators*, ``Brick.Widgets.Core.hLimit`` and -``Brick.Widgets.Core.vLimit``. These combinators take widgets and turn -them into widgets with a ``Fixed`` size (in the relevant dimension) and -run their rendering functions in a modified rendering context with a -restricted rendering area. - -For example, the following will center a string in 30 columns, leaving -room for something to be placed next to it as the terminal width -changes: - -.. code:: haskell - - let w = hLimit 30 $ hCenter $ str "Hello, world!" - -The Attribute Map ------------------ - -The rendering context contains an attribute map (see `How Attributes -Work`_ and `appAttrMap: Managing Attributes`_) which is used to look up -attribute names from the drawing specification. The map originates from -``Brick.Main.appAttrMap`` and can be manipulated on a per-widget basis -using ``Brick.Widgets.Core.updateAttrMap``. - -The Active Border Style ------------------------ - -Widgets in the ``Brick.Widgets.Border`` module draw border characters -(horizontal, vertical, and boxes) between and around other widgets. To -ensure that widgets across your application share a consistent visual -style, border widgets consult the rendering context's *active border -style*, a value of type ``Brick.Widgets.Border.Style``, to get the -characters used to draw borders. - -The default border style is ``Brick.Widgets.Border.Style.unicode``. To -change border styles, use the ``Brick.Widgets.Core.withBorderStyle`` -combinator to wrap a widget and change the border style it uses when -rendering. For example, this will use the ``ascii`` border style instead -of ``unicode``: - -.. code:: haskell - - let w = withBorderStyle Brick.Widgets.Border.Style.ascii $ - Brick.Widgets.Border.border $ str "Hello, world!" - -How Attributes Work -=================== - -In addition to letting us map names to attributes, attribute maps -provide hierarchical attribute inheritance: a more specific attribute -derives any properties (e.g. background color) that it does not specify -from more general attributes in hierarchical relationship to it, letting -us customize only the parts of attributes that we want to change without -having to repeat ourselves. - -For example, this draws a string with a foreground color of ``white`` on -a background color of ``blue``: - -.. code:: haskell - - let w = withAttr specificAttr $ str "foobar" - generalAttr = attrName "general" - specificAttr = attrName "general" <> attrName "specific" - myMap = attrMap defAttr [ (generalAttr, bg blue) - , (specificAttr, fg white) - ] - -Functions ``Brick.Util.fg`` and ``Brick.Util.bg`` specify -partial attributes, and map lookups start with the desired name -(``general/specific`` in this case) and walk up the name hierarchy (to -``general``), merging partial attribute settings as they go, letting -already-specified attribute settings take precedence. Finally, any -attribute settings not specified by map lookups fall back to the map's -*default attribute*, specified above as ``Graphics.Vty.defAttr``. In -this way, if you want everything in your application to have a ``blue`` -background color, you only need to specify it *once*: in the attribute -map's default attribute. Any other attribute names can merely customize -the foreground color. - -In addition to using the attribute map provided by ``appAttrMap``, -the map can be customized on a per-widget basis by using the attribute -map combinators: - -* ``Brick.Widgets.Core.updateAttrMap`` -* ``Brick.Widgets.Core.forceAttr`` -* ``Brick.Widgets.Core.withDefAttr`` - -Viewports -========= - -A *viewport* is a scrollable window onto another widget. Viewports have -a *scrolling direction* of type ``Brick.Types.ViewportType`` which can -be one of: - -* ``Horizontal``: the viewport can only scroll horizontally. -* ``Vertical``: the viewport can only scroll vertically. -* ``Both``: the viewport can scroll both horizontally and vertically. - -The ``Brick.Widgets.Core.viewport`` combinator takes another widget and -embeds it in a named viewport. We name the viewport so that we can -keep track of its scrolling state in the renderer, and so that you can -make scrolling requests. The viewport's name is its handle for these -operations (see `Scrolling Viewports in Event Handlers`_). *The viewport -name must be unique across your interface.* - -For example, the following puts a string in a horizontally-scrollable -viewport: - -.. code:: haskell - - let w = viewport (Name "myViewport") Horizontal $ str "Hello, world!" - -The above example is incomplete. A ``viewport`` specification means that -the widget in the viewport will be placed in a viewport window that is -``Greedy`` in both directions (see `Available Rendering Area`_). This -is suitable if we want the viewport size to be the size of the entire -terminal window, but if we want to embed this scrollable viewport -somewhere in our interface, we want to control its dimensions. To do so, -we use the limiting combinators (see `Limiting Rendering Area`_): - -.. code:: haskell - - let w = hLimit 5 $ - vLimit 1 $ - viewport (Name "myViewport") Horizontal $ str "Hello, world!" - -Now the example produces a scrollable window one row high and five -columns wide initially showing "Hello". The next two sections discuss -the two ways in which this viewport can be scrolled. - -Scrolling Viewports in Event Handlers -------------------------------------- - -The most direct way to scroll a viewport is to make *scrolling requests* -in the ``EventM`` event-handling monad. Scrolling requests ask the -render to update the state of a viewport the next time the user -interface is rendered. Those state updates will be made with respect to -the *previous* viewport state. This approach is the best approach to use -to scroll widgets that have no notion of a cursor. For cursor-based -scrolling, see `Scrolling Viewports With Visibility Requests`_. - -To make scrolling requests, we first create a -``Brick.Main.ViewportScroll`` from a viewport name with -``Brick.Main.viewportScroll``: - -.. code:: haskell - - let vp = viewportScroll (Name "myViewport") - -The ``ViewportScroll`` record type contains a number of scrolling -functions for making scrolling requests: - -.. code:: haskell - - hScrollPage :: Direction -> EventM () - hScrollBy :: Int -> EventM () - hScrollToBeginning :: EventM () - hScrollToEnd :: EventM () - vScrollPage :: Direction -> EventM () - vScrollBy :: Int -> EventM () - vScrollToBeginning :: EventM () - vScrollToEnd :: EventM () - -In each case the scrolling function scrolls the viewport by the -specified amount in the specified direction; functions prefixed with -``h`` scroll horizontally and functions prefixed with ``v`` scroll -vertically. - -Scrolling operations do nothing when they don't make sense for the -specified viewport; scrolling a ``Vertical`` viewport horizontally is a -no-op, for example. - -Using ``viewportScroll`` and the ``myViewport`` example given above, we -can write an event handler that scrolls the "Hello, world!" viewport one -column to the right: - -.. code:: haskell - - myHandler :: s -> e -> EventM (Next s) - myHandler s e = do - let vp = viewportScroll (Name "myViewport") - hScrollBy vp 1 - continue s - -Scrolling Viewports With Visibility Requests --------------------------------------------- - -When we need to scroll widgets only when a cursor in the viewport leaves -the viewport's bounds, we need to use *visibility requests*. A -visibility request is a hint to the renderer that some element of a -widget inside a viewport should be made visible, i.e., that the viewport -should be scrolled to bring the requested element into view. - -To use a visibility request to make a widget in a viewport visible, we -simply wrap it with ``visible``: - -.. code:: haskell - - let w = viewport (Name "myViewport") Horizontal $ - (visible $ str "Hello," <+> (str " world!") - -This example requests that the "``myViewport``" viewport be scrolled so -that "Hello," is visible. We could extend this example with a value -in the application state indicating which word in our string should -be visible and then use that to change which string gets wrapped with -``visible``; this is the basis of cursor-based scrolling. - -Note that a visibility request does not change the state of a viewport -*if the requested widget is already visible*! This important detail is -what makes visibility requests so powerful, because they can be used to -capture various cursor-based scenarios: - -* The ``Brick.Widgets.Edit`` widget uses a visibility request to make its - 1x1 cursor position visible, thus making the text editing widget fully - scrollable *while being entirely scrolling-unaware*. -* The ``Brick.Widgets.List`` widget uses a visibility request to make - its selected item visible regardless of its size, which makes - the list widget both scrolling-unaware and also makes it support - variable-height items for free. - -Viewport Restrictions ---------------------- - -Viewports impose one restriction: a viewport that is scrollable in some -direction can only embed a widget that has a ``Fixed`` size in that -direction. This extends to ``Both`` type viewports: they can only embed -widgets that are ``Fixed`` in both directions. This restriction is -because when viewports embed a widget, they relax the rendering area -constraint in the rendering context, but doing so to a large enough -number for ``Greedy`` widgets would result in a widget that is too big -and not scrollable in a useful way. - -Violating this restriction will result in a runtime exception. - -Implementing Your Own Widgets -============================= - -``brick`` exposes all of the internals you need to implement your own -widgets. Those internals, together with ``Graphics.Vty``, can be used to -create widgets from the ground up. We start by writing a constructor -function: - -.. code:: haskell - - myWidget :: ... -> Widget - myWidget ... = - Widget Fixed Fixed $ do - ... - -We specify the horizontal and vertical growth policies of the widget -as ``Fixed`` in this example, although they should be specified -appropriately (see `How Widgets and Rendering Work`_). Lastly we specify -the *rendering function*, a function of type - -.. code:: haskell - - render :: RenderM Result - -which is a function returning a ``Brick.Types.Result``: - -.. code:: haskell - - data Result = - Result { image :: Graphics.Vty.Image - , cursors :: [Brick.Types.CursorLocation] - , visibilityRequests :: [Brick.Types.VisibilityRequest] - } - -The ``RenderM`` monad gives us access to the rendering context (see `How -Widgets and Rendering Work`_) via the ``Brick.Types.getContext`` -function. The context type is: - -.. code:: haskell - - data Context = - Context { ctxAttrName :: AttrName - , availWidth :: Int - , availHeight :: Int - , ctxBorderStyle :: BorderStyle - , ctxAttrMap :: AttrMap - } - -and has `lens` fields exported as described in `Conventions`_. - -The job of the rendering function is to return a rendering result which, -at a minimum, means producing a ``vty`` ``Image``. In addition, if you -so choose, you can also return one or more cursor positions in the -``cursors`` field of the ``Result`` as well as visibility requests (see -`Viewports`_) in the ``visibilityRequests`` field. Returned visibility -requests and cursor positions should be relative to the upper-left -corner of your widget, ``Location (0, 0)``. When your widget is placed -in others, such as boxes, the ``Result`` data you returned will be -offset (as described in `Rendering Sub-Widgets`_) to result in correct -coordinates once the entire interface has been rendered. - -Using the Rendering Context ---------------------------- - -The most important fields of the context are the rendering area fields -``availWidth`` and ``availHeight``. These fields must be used to -determine how much space your widget has to render. - -To perform an attribute lookup in the attribute map for the context's -current attribute, use ``Brick.Types.attrL``. - -For example, to build a widget that always fills the available width and -height with a fill character using the current attribute, we could -write: - -.. code:: haskell - - myFill :: Char -> Widget - myFill ch = - Widget Greedy Greedy $ do - ctx <- getContext - let a = ctx^.attrL - return $ Result (Graphics.Vty.charFill ch a (ctx^.availWidth) (ctx^.availHeight)) - [] [] - -Rendering Sub-Widgets ---------------------- - -If your custom widget wraps another, then in addition to rendering the -wrapped widget and augmenting its returned ``Result`` *it must also -translate the resulting cursor locations and visibility requests*. -This is vital to maintaining the correctness of cursor locations and -visbility locations as widget layout proceeds. To do so, use the -``Brick.Widgets.Core.addResultOffset`` function to offset the elements -of a ``Result`` by a specified amount. The amount depends on the nature -of the offset introduced by your wrapper widget's logic. - -Widgets are not required to respect the rendering context's width and -height restrictions. Widgets may be embedded in viewports or translated -so they must render without cropping to work in those scenarios. -However, widgets rendering other widgets *should* enforce the rendering -context's constraints to avoid using more space than is available. The -``Brick.Widgets.Core.cropToContext`` function is provided to make this -easy: - -.. code:: haskell - - let w = cropToContext someWidget - -Widgets wrapped with ``cropToContext`` can be safely embedded in other -widgets. If you don't want to crop in this way, you can use any of -``vty``'s cropping functions to operate on the ``Result`` image as -desired. - -.. _vty: https://github.com/coreyoconnor/vty -.. _Hackage: http://hackage.haskell.org/ -.. _lens: http://hackage.haskell.org/package/lens +abstraction, combinators for expressing user interface layouts, and +infrastructure for handling events. + +This documentation is intended to provide a high-level overview of +the library's design along with guidance for using it, but details on +specific functions can be found in the Haddock documentation. + +The process of writing an application using ``brick`` entails writing +two important functions: + +- A *drawing function* that turns your application state into a + specification of how your interface should be drawn, and +- An *event handler* that takes your application state and an input + event and decides whether to change the state or quit the program. + +We write drawing functions in ``brick`` using an extensive set of +primitives and combinators to place text on the screen, set its +attributes (e.g. foreground color), and express layout constraints (e.g. +padding, centering, box layouts, scrolling viewports, etc.). + +These functions get packaged into an ``App`` structure that we hand off +to the ``brick`` library's main event loop. We'll cover that in detail +in `The App Type`_. + +Installation +------------ + +``brick`` can be installed in the "usual way," either by installing +the latest `Hackage`_ release or by cloning the GitHub repository and +building locally. + +To install from Hackage:: + + $ cabal update + $ cabal install brick + +To clone and build locally:: + + $ git clone https://github.com/jtdaugherty/brick.git + $ 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 +----------------------------------- + +``brick`` includes a large collection of feature-specific demonstration +programs. These programs are not built by default but can be built by +passing the ``demos`` flag to ``cabal install``, e.g.:: + + $ cabal install brick -f demos + +Conventions +=========== + +``brick`` has some API conventions worth knowing about as you read this +documentation and as you explore the library source and write your own +programs. + +- Use of `microlens`_ packages: ``brick`` uses the ``microlens`` family + of packages internally and also exposes lenses for many types in the + library. However, if you prefer not to use the lens interface in your + program, all lens interfaces have non-lens equivalents exported by + the same module. In general, the "``L``" suffix on something tells + you it is a lens; the name without the "``L``" suffix is the non-lens + version. You can get by without using ``brick``'s lens interface + but your life will probably be much more pleasant if you use lenses + to modify your application state once it becomes sufficiently + complex (see `appHandleEvent: Handling Events`_ and `Event Handlers + for Component State`_). +- Attribute names: some modules export attribute names (see `How + Attributes Work`_) associated with user interface elements. These tend + to end in an "``Attr``" suffix (e.g. ``borderAttr``). In addition, + hierarchical relationships between attributes are documented in + Haddock documentation. +- Use of qualified Haskell identifiers: in this document, where + sensible, I will use fully-qualified identifiers whenever I mention + something for the first time or whenever I use something that is + not part of ``brick``. Use of qualified names is not intended to + produce executable examples, but rather to guide you in writing your + ``import`` statements. + +Compiling Brick Applications +============================ + +Brick applications must be compiled with the threaded RTS using the GHC +``-threaded`` option. + +The ``App`` Type +================ + +To use the library we must provide it with a value of type +``Brick.Main.App``. This type is a record type whose fields perform +various functions: + +.. code:: haskell + + data App s e n = + App { appDraw :: s -> [Widget n] + , appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n) + , appHandleEvent :: BrickEvent n e -> EventM n s () + , appStartEvent :: EventM n s () + , appAttrMap :: s -> AttrMap + } + +The ``App`` type is parameterized over three types. These type variables +will appear in the signatures of many library functions and types. They +are: + +- The **application state type** ``s``: the type of data that will + evolve over the course of the application's execution. Your + application will provide the library with its starting value and event + handling will transform it as the program executes. When a ``brick`` + application exits, the final application state will be returned. +- The **event type** ``e``: the type of custom application events + that your application will need to produce and handle in + ``appHandleEvent``. All applications will be provided with events from + the underlying ``vty`` library, such as keyboard events or resize + events; this type variable indicates the type of *additional* events + the application will need. For more details, see `Using Your Own Event + Type`_. +- The **resource name type** ``n``: during application execution we + sometimes need a way to refer to rendering state, such as the space + taken up by a given widget, the state for a scrollable viewport, a + mouse click, or a cursor position. For these situations we need a + unique handle called a *resource name*. The type ``n`` specifies the + name type the application will use to identify these bits of state + produced and managed by the renderer. The resource name type must be + provided by your application; for more details, see `Resource Names`_. + +The various fields of ``App`` will be described in the sections below. + +Running an Application +---------------------- + +To run an ``App``, we pass it to ``Brick.Main.defaultMain`` or +``Brick.Main.customMain`` along with an initial application state value: + +.. code:: haskell + + main :: IO () + main = do + let app = App { ... } + initialState = ... + finalState <- defaultMain app initialState + -- Use finalState and exit + +The ``customMain`` function is for more advanced uses; for details see +`Using Your Own Event Type`_. + +``appDraw``: Drawing an Interface +--------------------------------- + +The value of ``appDraw`` is a function that turns the current +application state into a list of *layers* of type ``Widget``, listed +topmost first, that will make up the interface. Each ``Widget`` gets +turned into a ``vty`` layer and the resulting layers are drawn to the +terminal. + +The ``Widget`` type is the type of *drawing instructions*. The body of +your drawing function will use one or more drawing functions to build or +transform ``Widget`` values to describe your interface. These +instructions will then be executed with respect to three things: + +- The size of the terminal: the size of the terminal determines how many + ``Widget`` values behave. For example, fixed-size ``Widget`` values + such as text strings behave the same under all conditions (and get + cropped if the terminal is too small) but layout combinators such as + ``Brick.Widgets.Core.vBox`` or ``Brick.Widgets.Center.center`` use the + size of the terminal to determine how to lay other widgets out. See + `How Widgets and Rendering Work`_. +- The application's attribute map (``appAttrMap``): drawing functions + requesting the use of attributes cause the attribute map to be + consulted. See `How Attributes Work`_. +- The state of scrollable viewports: the state of any scrollable + viewports on the *previous* drawing will be considered. For more + details, see `Viewports`_. + +The ``appDraw`` function is called when the event loop begins to draw +the application as it initially appears. It is also called right after +an event is processed by ``appHandleEvent``. Even though the function +returns a specification of how to draw the entire screen, the underlying +``vty`` library goes to some trouble to efficiently update only the +parts of the screen that have changed so you don't need to worry about +this. + +Where do I find drawing functions? +********************************** + +The most important module providing drawing functions is +``Brick.Widgets.Core``. Beyond that, any module in the ``Brick.Widgets`` +namespace provides specific kinds of functionality. + +``appHandleEvent``: Handling Events +----------------------------------- + +The value of ``appHandleEvent`` is a function that decides how to modify +the application state as a result of an event: + +.. code:: haskell + + appHandleEvent :: BrickEvent n e -> EventM n s () + +``appHandleEvent`` is responsible for deciding how to change the state +based on incoming events. The single parameter to the event handler is +the event to be handled. Its type variables ``n`` and ``e`` correspond +to the *resource name type* and *event type* of your application, +respectively, and must match the corresponding types in ``App`` and +``EventM``. + +The ``EventM`` monad is parameterized on the *resource name type* +``n`` and your application's state type ``s``. The ``EventM`` monad +is a state monad over ``s``, so one way to access and modify your +application's state in an event handler is to use the ``MonadState`` +type class and associated operations from the ``mtl`` package. The +recommended approach, however, is to use the lens operations from the +``microlens-mtl`` package with lenses to perform concise state updates. +We'll cover this topic in more detail in `Event Handlers for Component +State`_. + +Once the event handler has performed any relevant state updates, it can +also indicate what should happen once the event handler has finished +executing. By default, after an event handler has completed, Brick will +redraw the screen with the application state (by calling ``appDraw``) +and wait for the next input event. However, there are two other options: + +* ``Brick.Main.halt``: halt the event loop. The application state as it + exists after the event handler completes is returned to the caller + of ``defaultMain`` or ``customMain``. +* ``Brick.Main.continueWithoutRedraw``: continue executing the event + loop, but do not redraw the screen using the new state before waiting + for another input event. This is faster than the default continue + behavior since it doesn't redraw the screen; it just leaves up the + previous screen contents. This function is only useful when you know + that your event handler's state change(s) won't cause anything on + the screen to change. Use this only when you are certain that no + redraw of the screen is needed *and* when you are trying to address a + performance problem. (See also `The Rendering Cache`_ for details on + how to deal with rendering performance issues.) + +The ``EventM`` monad is a transformer around ``IO`` so I/O is possible +in this monad by using ``liftIO``. Keep in mind, however, that event +handlers should execute as quickly as possible to avoid introducing +screen redraw latency. Consider using background threads to work +asynchronously when handling an event would otherwise cause redraw +latency. + +``EventM`` is also used to make scrolling requests to the renderer (see +`Viewports`_), obtain named extents (see `Extents`_), and other duties. + +Event Handlers for Component State +********************************** + +The top-level ``appHandleEvent`` handler is responsible for managing +the application state, but it also needs to be able to update the state +associated with UI components such as those that come with Brick. + +For example, consider an application that uses Brick's built-in text +editor from ``Brick.Widgets.Edit``. The built-in editor is similar to +the main application in that it has three important elements: + +* The editor state of type ``Editor t n``: this stores the editor's + contents, cursor position, etc. +* The editor's drawing function, ``renderEditor``: this is responsible + for drawing the editor in the UI. +* The editor's event handler, ``handleEditorEvent``: this is responsible + for updating the editor's contents and cursor position in response to + key events. + +To use the built-in editor, the application must: + +* Embed an ``Editor t n`` somewhere in the application state ``s``, +* Render the editor's state at the appropriate place in ``appDraw`` with + ``renderEditor``, and +* Dispatch events to the editor in the ``appHandleEvent`` with + ``handleEditorEvent``. + +An example application state using an editor might look like this: + +.. code:: haskell + + data MyState n = MyState { _editor :: Editor Text n } + makeLenses ''MyState + +This declares the ``MyState`` type with an ``Editor`` contained within +it and uses Template Haskell to generate a lens, ``editor``, to allow us +to easily update the editor state in our event handler. + +To dispatch events to the ``editor`` we'd start by writing the +application event handler: + +.. code:: haskell + + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + ... + +But there's a problem: ``handleEditorEvent``'s type indicates that it +can only run over a state of type ``Editor t n``, but our handler runs +on ``MyState``. Specifically, ``handleEditorEvent`` has this type: + +.. code:: haskell + + handleEditorEvent :: BrickEvent n e -> EventM n (Editor t n) () + +This means that to use ``handleEditorEvent``, it must be composed +into the application's event handler, but since the state types ``s`` +and ``Editor t n`` do not match, we need a way to compose these event +handlers. There are two ways to do this: + +* Use ``Lens.Micro.Mtl.zoom`` from the ``microlens-mtl`` package + (re-exported by ``Brick.Types`` for convenience). This function is + required when you want to change the state type to a field embedded in + your application state using a lens. For example: + +.. code:: haskell + + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + zoom editor $ handleEditorEvent e + +* Use ``Brick.Types.nestEventM``: this function lets you provide a state + value and run ``EventM`` using that state. The following + ``nestEventM`` example is equivalent to the ``zoom`` example above: + +.. code:: haskell + + import Lens.Micro (_1) + import Lens.Micro.Mtl (use, (.=)) + + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + editorState <- use editor + (newEditorState, ()) <- nestEventM editorState $ do + handleEditorEvent e + editor .= newEditorState + +The ``zoom`` function, together with lenses for your application state's +fields, is by far the best way to manage your state in ``EventM``. As +you can see from the examples above, the ``zoom`` approach avoids a lot +of boilerplate. The ``nestEventM`` approach is provided in cases where +the state that you need to mutate is not easily accessed by ``zoom``. + +Finally, if you prefer to avoid the use of lenses, you can always use +the ``MonadState`` API to get, put, and modify your state. Keep in +mind that the ``MonadState`` approach will still require the use of +``nestEventM`` when events scoped to widget states such as ``Editor`` +need to be handled. + +Using Your Own Event Type +************************* + +Since we often need to communicate application-specific events beyond +Vty input events to the event handler, brick supports embedding your +application's custom events in the stream of ``BrickEvent``-s that +your handler will receive. The type of these events is the type ``e`` +mentioned in ``BrickEvent n e`` and ``App s e n``. + +Note: ordinarily your application will not have its own custom event +type, so you can leave this type unused (e.g. ``App MyState e MyName``) +or just set it to unit (``App MyState () MyName``). + +Here's an example of using a custom event type. Suppose that you'd like +to be able to handle counter events in your event handler. First we +define the counter event type: + +.. code:: haskell + + data CounterEvent = Counter Int + +With this type declaration we can now use counter events in our app by +using the application type ``App s CounterEvent n``. To handle these +events we'll just need to check for ``AppEvent`` values in the event +handler: + +.. code:: haskell + + myEvent :: BrickEvent n CounterEvent -> EventM n s () + myEvent (AppEvent (Counter i)) = ... + +The next step is to actually *generate* our custom events and +inject them into the ``brick`` event stream so they make it to the +event handler. To do that we need to create a ``BChan`` for our +custom events, provide that ``BChan`` to ``brick``, and then send +our events over that channel. Once we've created the channel with +``Brick.BChan.newBChan``, we provide it to ``brick`` with +``customMain`` instead of ``defaultMain``: + +.. code:: haskell + + main :: IO () + main = do + eventChan <- Brick.BChan.newBChan 10 + let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig + initialVty <- buildVty + finalState <- customMain initialVty buildVty + (Just eventChan) app initialState + -- Use finalState and exit + +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. 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: + +.. code:: haskell + + counterThread :: Brick.BChan.BChan CounterEvent -> IO () + counterThread chan = do + Brick.BChan.writeBChan chan $ Counter 1 + +Bounded Channels +**************** + +A ``BChan``, or *bounded channel*, can hold a limited number of +items before attempts to write new items will block. In the call to +``newBChan`` above, the created channel has a capacity of 10 items. +Use of a bounded channel ensures that if the program cannot process +events quickly enough then there is a limit to how much memory will +be used to store unprocessed events. Thus the chosen capacity should +be large enough to buffer occasional spikes in event handling latency +without inadvertently blocking custom event producers. Each application +will have its own performance characteristics that determine the best +bound for the event channel. In general, consider the performance of +your event handler when choosing the channel capacity and design event +producers so that they can block if the channel is full. + +``appStartEvent``: Starting up +------------------------------ + +When an application starts, it may be desirable to perform some of +the duties typically only possible when an event has arrived, such as +setting up initial scrolling viewport state. Since such actions can only +be performed in ``EventM`` and since we do not want to wait until the +first event arrives to do this work in ``appHandleEvent``, the ``App`` +type provides ``appStartEvent`` function for this purpose: + +.. code:: haskell + + appStartEvent :: EventM n s () + +This function is a handler action to run on the initial application +state. This function is invoked once and only once, at application +startup. This might be a place to make initial viewport scroll requests +or make changes to the Vty environment. You will probably just want +to use ``return ()`` as the implementation of this function for most +applications. + +``appChooseCursor``: Placing the Cursor +--------------------------------------- + +The rendering process for a ``Widget`` may return information about +where that widget would like to place the cursor. For example, a text +editor will need to report a cursor position. However, since a +``Widget`` may be a composite of many such cursor-placing widgets, we +have to have a way of choosing which of the reported cursor positions, +if any, is the one we actually want to honor. + +To decide which cursor placement to use, or to decide not to show one at +all, we set the ``App`` type's ``appChooseCursor`` function: + +.. code:: haskell + + appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n) + +The event loop renders the interface and collects the +``Brick.Types.CursorLocation`` values produced by the rendering process +and passes those, along with the current application state, to this +function. Using your application state (to track which text input box +is "focused," say) you can decide which of the locations to return or +return ``Nothing`` if you do not want to show a cursor. + +Many widgets in the rendering process can request cursor placements, but +it is up to our application to determine which one (if any) should be +used. Since we can only show at most a single cursor in the terminal, +we need to decide which location to show. One way is by looking at the +resource name contained in the ``cursorLocationName`` field. The name +value associated with a cursor location will be the name used to request +the cursor position with ``Brick.Widgets.Core.showCursor``. + +``Brick.Main`` provides various convenience functions to make cursor +selection easy in common cases: + +* ``neverShowCursor``: never show any cursor. +* ``showFirstCursor``: always show the first cursor request given; good + for applications with only one cursor-placing widget. +* ``showCursorNamed``: show the cursor with the specified resource name + or show no cursor if the name was not associated with any requested + cursor position. + +For example, this widget requests a cursor placement on the first +"``o``" in "``foo``" associated with the cursor name ``CustomName``: + +.. code:: haskell + + data MyName = CustomName + + let w = showCursor CustomName (Brick.Types.Location (1, 0)) + (Brick.Widgets.Core.str "foobar") + +The event handler for this application would use ``MyName`` as its +resource name type ``n`` and would be able to pattern-match on +``CustomName`` to match cursor requests when this widget is rendered: + +.. code:: haskell + + myApp = + App { ... + , appChooseCursor = \_ -> showCursorNamed CustomName + } + +See the next section for more information on using names. + +Resource Names +-------------- + +We saw above in `appChooseCursor: Placing the Cursor`_ that resource +names are used to describe cursor locations. Resource names are also +used to name other kinds of resources: + +* viewports (see `Viewports`_) +* rendering extents (see `Extents`_) +* mouse events (see `Mouse Support`_) + +Assigning names to these resource types allows us to distinguish between +events based on the part of the interface to which an event is related. + +Your application must provide some type of name. For simple applications +that don't make use of resource names, you may use ``()``. But if your +application has more than one named resource, you *must* provide a type +capable of assigning a unique name to every resource that needs one. + +A Note of Caution +***************** + +Resource names can be assigned to any of the resource types mentioned +above, but some resource types--viewports, extents, the render cache, +and cursor locations--form separate resource namespaces. So, for +example, the same name can be assigned to both a viewport and an extent, +since the ``brick`` API provides access to viewports and extents using +separate APIs and data structures. However, if the same name is used for +two resources of the same kind, it is undefined *which* of those you'll +be getting access to when you go to use one of those resources in your +event handler. + +For example, if the same name is assigned to two viewports: + +.. code:: haskell + + data Name = Viewport1 + + ui :: Widget Name + ui = (viewport Viewport1 Vertical $ str "Foo") <+> + (viewport Viewport1 Vertical $ str "Bar") <+> + +then in ``EventM`` when we attempt to scroll the viewport ``Viewport1`` +we don't know which of the two uses of ``Viewport1`` will be affected: + +.. code:: haskell + + let vp = viewportScroll Viewport1 + vScrollBy vp 1 + +The solution is to ensure that for a given resource type (in this case +viewport), a unique name is assigned in each use. + +.. code:: haskell + + data Name = Viewport1 | Viewport2 + + ui :: Widget Name + ui = (viewport Viewport1 Vertical $ str "Foo") <+> + (viewport Viewport2 Vertical $ str "Bar") <+> + +``appAttrMap``: Managing Attributes +----------------------------------- + +In ``brick`` we use an *attribute map* to assign attributes to elements +of the interface. Rather than specifying specific attributes when +drawing a widget (e.g. red-on-black text) we specify an *attribute name* +that is an abstract name for the kind of thing we are drawing, e.g. +"keyword" or "e-mail address." We then provide an attribute map which +maps those attribute names to actual attributes. This approach lets us: + +* Change the attributes at runtime, letting the user change the + attributes of any element of the application arbitrarily without + forcing anyone to build special machinery to make this configurable; +* Write routines to load saved attribute maps from disk; +* Provide modular attribute behavior for third-party components, where + we would not want to have to recompile third-party code just to change + attributes, and where we would not want to have to pass in attribute + arguments to third-party drawing functions. + +This lets us put the attribute mapping for an entire app, regardless of +use of third-party widgets, in one place. + +To create a map we use ``Brick.AttrMap.attrMap``, e.g., + +.. code:: haskell + + App { ... + , appAttrMap = const $ attrMap Graphics.Vty.defAttr [(someAttrName, fg blue)] + } + +To use an attribute map, we specify the ``App`` field ``appAttrMap`` as +the function to return the current attribute map each time rendering +occurs. This function takes the current application state, so you may +choose to store the attribute map in your application state. You may +also choose not to bother with that and to just set ``appAttrMap = const +someMap``. + +To draw a widget using an attribute name in the map, use +``Brick.Widgets.Core.withAttr``. For example, this draws a string with a +``blue`` background: + +.. code:: haskell + + let w = withAttr blueBg $ str "foobar" + blueBg = attrName "blueBg" + myMap = attrMap defAttr [ (blueBg, Brick.Util.bg Graphics.Vty.blue) + ] + +For complete details on how attribute maps and attribute names work, see +the Haddock documentation for the ``Brick.AttrMap`` module. See also +`How Attributes Work`_. + +How Widgets and Rendering Work +============================== + +When ``brick`` renders a ``Widget``, the widget's rendering routine is +evaluated to produce a ``vty`` ``Image`` of the widget. The widget's +rendering routine runs with some information called the *rendering +context* that contains: + +* The size of the area in which to draw things +* The name of the current attribute to use to draw things +* The map of attributes to use to look up attribute names +* The active border style to use when drawing borders + +Available Rendering Area +------------------------ + +The most important element in the rendering context is the rendering +area: This part of the context tells the widget being drawn how many +rows and columns are available for it to consume. When rendering begins, +the widget being rendered (i.e. a layer returned by an ``appDraw`` +function) gets a rendering context whose rendering area is the size of +the terminal. This size information is used to let widgets take up that +space if they so choose. For example, a string "Hello, world!" will +always take up one row and 13 columns, but the string "Hello, world!" +*centered* will always take up one row and *all available columns*. + +How widgets use space when rendered is described in two pieces of +information in each ``Widget``: the widget's horizontal and vertical +growth policies. These fields have type ``Brick.Types.Size`` and can +have the values ``Fixed`` and ``Greedy``. Note that these values are +merely *descriptive hints* about the behavior of the rendering function, +so it's important that they accurately describe the widget's use of +space. + +A widget advertising a ``Fixed`` size in a given dimension is a widget +that will always consume the same number of rows or columns no +matter how many it is given. Widgets can advertise different +vertical and horizontal growth policies for example, the +``Brick.Widgets.Center.hCenter`` function centers a widget and is +``Greedy`` horizontally and defers to the widget it centers for vertical +growth behavior. + +These size policies govern the box layout algorithm that is at +the heart of every non-trivial drawing specification. When we use +``Brick.Widgets.Core.vBox`` and ``Brick.Widgets.Core.hBox`` to +lay things out (or use their binary synonyms ``<=>`` and ``<+>``, +respectively), the box layout algorithm looks at the growth policies of +the widgets it receives to determine how to allocate the available space +to them. + +For example, imagine that the terminal window is currently 10 rows high +and 50 columns wide. We wish to render the following widget: + +.. code:: haskell + + let w = (str "Hello," <=> str "World!") + +Rendering this to the terminal will result in "Hello," and "World!" +underneath it, with 8 rows unoccupied by anything. But if we wished to +render a vertical border underneath those strings, we would write: + +.. code:: haskell + + let w = (str "Hello," <=> str "World!" <=> vBorder) + +Rendering this to the terminal will result in "Hello," and "World!" +underneath it, with 8 rows remaining occupied by vertical border +characters ("``|``") one column wide. The vertical border widget is +designed to take up however many rows it was given, but rendering the +box layout algorithm has to be careful about rendering such ``Greedy`` +widgets because they won't leave room for anything else. Since the box +widget cannot know the sizes of its sub-widgets until they are rendered, +the ``Fixed`` widgets get rendered and their sizes are used to determine +how much space is left for ``Greedy`` widgets. + +When using widgets it is important to understand their horizontal and +vertical space behavior by knowing their ``Size`` values. Those should +be made clear in the Haddock documentation. + +The rendering context's specification of available space will also +govern how widgets get cropped, since all widgets are required to render +to an image no larger than the rendering context specifies. If they do, +they will be forcibly cropped. + +Limiting Rendering Area +----------------------- + +If you'd like to use a ``Greedy`` widget but want to limit how much +space it consumes, you can turn it into a ``Fixed`` widget by using +one of the *limiting combinators*, ``Brick.Widgets.Core.hLimit`` and +``Brick.Widgets.Core.vLimit``. These combinators take widgets and turn +them into widgets with a ``Fixed`` size (in the relevant dimension) and +run their rendering functions in a modified rendering context with a +restricted rendering area. + +For example, the following will center a string in 30 columns, leaving +room for something to be placed next to it as the terminal width +changes: + +.. code:: haskell + + let w = hLimit 30 $ hCenter $ str "Hello, world!" + +The Attribute Map +----------------- + +The rendering context contains an attribute map (see `How Attributes +Work`_ and `appAttrMap: Managing Attributes`_) which is used to look up +attribute names from the drawing specification. The map originates from +``Brick.Main.appAttrMap`` and can be manipulated on a per-widget basis +using ``Brick.Widgets.Core.updateAttrMap``. + +The Active Border Style +----------------------- + +Widgets in the ``Brick.Widgets.Border`` module draw border characters +(horizontal, vertical, and boxes) between and around other widgets. To +ensure that widgets across your application share a consistent visual +style, border widgets consult the rendering context's *active border +style*, a value of type ``Brick.Widgets.Border.Style``, to get the +characters used to draw borders. + +The default border style is ``Brick.Widgets.Border.Style.unicode``. To +change border styles, use the ``Brick.Widgets.Core.withBorderStyle`` +combinator to wrap a widget and change the border style it uses when +rendering. For example, this will use the ``ascii`` border style instead +of ``unicode``: + +.. code:: haskell + + let w = withBorderStyle Brick.Widgets.Border.Style.ascii $ + Brick.Widgets.Border.border $ str "Hello, world!" + +By default, borders in adjacent widgets do not connect to each other. +This can lead to visual oddities, for example, when horizontal borders +are drawn next to vertical borders by leaving a small gap like this: + +.. code:: text + + │─ + +You can request that adjacent borders connect to each other with +``Brick.Widgets.Core.joinBorders``. Two borders drawn with the +same attribute and border style, and both under the influence of +``joinBorders``, will produce a border like this instead: + +.. code:: text + + ├─ + +See `Joining Borders`_ for further details. + +How Attributes Work +=================== + +In addition to letting us map names to attributes, attribute maps +provide hierarchical attribute inheritance: a more specific attribute +derives any properties (e.g. background color) that it does not specify +from more general attributes in hierarchical relationship to it, letting +us customize only the parts of attributes that we want to change without +having to repeat ourselves. + +For example, this draws a string with a foreground color of ``white`` on +a background color of ``blue``: + +.. code:: haskell + + let w = withAttr specificAttr $ str "foobar" + generalAttr = attrName "general" + specificAttr = attrName "general" <> attrName "specific" + myMap = attrMap defAttr [ (generalAttr, bg blue) + , (specificAttr, fg white) + ] + +When drawing a widget, Brick keeps track of the current attribute it +is using to draw to the screen. The attribute it tracks is specified +by its *attribute name*, which is a hierarchical name referring to the +attribute in the attribute map. In the example above, the map contains +two attribute names: ``generalAttr`` and ``specificAttr``. Both names +are made up of segments: ``general`` is the first segment for both +names, and ``specific`` is the second segment for ``specificAttr``. +This tells Brick that ``specificAttr`` is a more specialized version +of ``generalAttr``. We'll see below how that affects the resulting +attributes that Brick uses. + +When it comes to drawing something on the screen with either of these +attributes, Brick looks up the desired attribute name in the map +and uses the result to draw to the screen. In the example above, +``withAttr`` is used to tell Brick that when drawing ``str "foobar"``, +the attribute ``specificAttr`` should be used. Brick looks that name +up in the attribute map and finds a match: an attribute with a white +foreground color. However, what happens next is important: Brick then +looks up the more general attribute name derived from ``specificAttr``, +which it gets by removing the last segment in the name, ``specific``. +The resulting name, ``general``, is then looked up. The new result is +then *merged* with the initial lookup, yielding an attribute with a +white foreground color and a blue background color. This happens because +the ``specificAttr`` entry did not specify a background color. If it +had, that would have been used instead. In this way, we can create +inheritance relationships between attributes, much the same way CSS +supports inheritance of styles based on rule specificity. + +Brick uses Vty's attribute type, ``Attr``, which has three components: +foreground color, background color, and style. These three components +can be independently specified to have an explicit value, and any +component not explicitly specified can default to whatever the terminal +is currently using. Vty styles can be combined together, e.g. underline +and bold, so styles are cumulative. + +What if a widget attempts to draw with an attribute name that is not +specified in the map at all? In that case, the attribute map's "default +attribute" is used. In the example above, the default attribute for the +map is Vty's ``defAttr`` value, which means that the terminal's default +colors and style should be used. But that attribute can be customized +as well, and any attribute map lookup results will get merged with the +default attribute for the map. So, for example, if you'd like your +entire application background to be blue unless otherwise specified, you +could create an attribute map as follows: + +.. code:: haskell + + let myMap = attrMap (bg blue) [ ... ] + +This way, we can avoid repeating the desired background color and all of +the other map entries can just set foreground colors and styles where +needed. + +In addition to using the attribute map provided by ``appAttrMap``, the +map and attribute lookup behavior can be customized on a per-widget +basis by using various functions from ``Brick.Widgets.Core``: + +* ``updateAttrMap`` -- allows transformations of the attribute map, +* ``forceAttr`` -- forces all attribute lookups to map to the value of + the specified attribute name, +* ``withDefAttr`` -- changes the default attribute for the attribute map + to the one with the specified name, and +* ``overrideAttr`` -- creates attribute map lookup synonyms between + attribute names. + +Attribute Themes +================ + +Brick provides support for customizable attribute themes. This works as +follows: + +* The application provides a default theme built in to the program. +* The application customizes the theme by loading theme customizations + from a user-specified customization file. +* The application can save new customizations to files for later + re-loading. + +Customizations are written in an INI-style file. Here's an example: + +.. code:: ini + + [default] + default.fg = blue + default.bg = black + + [other] + someAttribute.fg = red + someAttribute.style = underline + otherAttribute.style = [underline, bold] + otherAttribute.inner.fg = white + +In the above example, the theme's *default attribute* -- the one that is +used when no other attributes are used -- is customized. Its foreground +and background colors are set. Then, other attributes specified by +the theme -- ``someAttribute`` and ``otherAttribute`` -- are also +customized. This example shows that styles can be customized, too, and +that a custom style can either be a single style (in this example, +``underline``) or a collection of styles to be applied simultaneously +(in this example, ``underline`` and ``bold``). Lastly, the hierarchical +attribute name ``otherAttribute.inner`` refers to an attribute name +with two components, ``otherAttribute <> inner``, similar to the +``specificAttr`` attribute described in `How Attributes Work`_. Full +documentation for the format of theme customization files can be found +in the module documentation for ``Brick.Themes``. + +The above example can be used in a ``brick`` application as follows. +First, the application provides a default theme: + +.. code:: haskell + + import Brick.Themes (Theme, newTheme) + import Brick (attrName) + import Brick.Util (fg, on) + import Graphics.Vty (defAttr, white, blue, yellow, magenta) + + defaultTheme :: Theme + defaultTheme = + newTheme (white `on` blue) + [ (attrName "someAttribute", fg yellow) + , (attrName "otherAttribute", fg magenta) + ] + +Notice that the attributes in the theme have defaults: ``someAttribute`` +will default to a yellow foreground color if it is not customized. (And +its background will default to the theme's default background color, +blue, if it not customized either.) Then, the application can customize +the theme with the user's customization file: + +.. code:: haskell + + import Brick.Themes (loadCustomizations) + + main :: IO () + main = do + customizedTheme <- loadCustomizations "custom.ini" defaultTheme + +Now we have a customized theme based on ``defaultTheme``. The next step +is to build an ``AttrMap`` from the theme: + +.. code:: haskell + + import Brick.Themes (themeToAttrMap) + + main :: IO () + main = do + customizedTheme <- loadCustomizations "custom.ini" defaultTheme + let mapping = themeToAttrMap customizedTheme + +The resulting ``AttrMap`` can then be returned by ``appAttrMap`` +as described in `How Attributes Work`_ and `appAttrMap: Managing +Attributes`_. + +If the theme is further customized at runtime, any changes can be saved +with ``Brick.Themes.saveCustomizations``. + +Wide Character Support and the ``TextWidth`` class +================================================== + +Brick attempts to support rendering wide characters in all widgets, +and the brick editor supports entering and editing wide characters. +Wide characters are those such as many Asian characters and emoji +that need more than a single terminal column to be displayed. + +Unfortunately, there is not a fully correct solution to determining +the character width that the user's terminal will use for a given +character. The current recommendation is to avoid use of wide characters +due to these issues. If you still must use them, you can read `vty`_'s +documentation for options that will affect character width calculations. + +As a result of supporting wide characters, it is important to know that +computing the length of a string to determine its screen width will +*only* work for single-column characters. So, for example, if you want +to support wide characters in your application, this will not work: + +.. code:: haskell + + let width = Data.Text.length t + +If the string contains any wide characters, their widths will not be +counted properly. In order to get this right, use the ``TextWidth`` type +class to compute the width: + +.. code:: haskell + + let width = Brick.Widgets.Core.textWidth t + +The ``TextWidth`` type class uses Vty's character width routine to +compute the width by looking up the string's characters in a Unicode +width table. If you need to compute the width of a single character, use +``Graphics.Text.wcwidth``. + +Extents +======= + +When an application needs to know where a particular widget was drawn +by the renderer, the application can request that the renderer record +the *extent* of the widget--its upper-left corner and size--and provide +access to it in an event handler. Extents are represented using Brick's +``Brick.Types.Extent`` type. In the following example, the application +needs to know where the bordered box containing "Foo" is rendered: + +.. code:: haskell + + ui = center $ border $ str "Foo" + +We don't want to have to care about the particulars of the layout to +find out where the bordered box got placed during rendering. To get this +information we request that the extent of the box be reported to us by +the renderer using a resource name: + +.. code:: haskell + + data Name = FooBox + + ui = center $ + reportExtent FooBox $ + border $ str "Foo" + +Now, whenever the ``ui`` is rendered, the extent of the bordered box +containing "Foo" will be recorded. We can then look it up in event +handlers in ``EventM``: + +.. code:: haskell + + mExtent <- Brick.Main.lookupExtent FooBox + case mExtent of + Nothing -> ... + Just (Extent _ upperLeft (width, height)) -> ... + +Paste Support +============= + +Some terminal emulators support "bracketed paste" mode. This feature +enables OS-level paste operations to send the pasted content as a +single chunk of data and bypass the usual input processing that the +application does. This enables more secure handling of pasted data since +the application can detect that a paste occurred and avoid processing +the pasted data as ordinary keyboard input. For more information, see +`bracketed paste mode`_. + +The Vty library used by brick provides support for bracketed pastes, but +this mode must be enabled. To enable paste mode, we need to get access +to the Vty library handle in ``EventM`` (in e.g. ``appHandleEvent``): + +.. code:: haskell + + import Control.Monad (when) + import qualified Graphics.Vty as V + + do + vty <- Brick.Main.getVtyHandle + let output = V.outputIface vty + when (V.supportsMode output V.BracketedPaste) $ + liftIO $ V.setMode output V.BracketedPaste True + +Once enabled, paste mode will generate Vty ``EvPaste`` events. These +events will give you the entire pasted content as a ``ByteString`` which +you must decode yourself if, for example, you expect it to contain UTF-8 +text data. + +Mouse Support +============= + +Some terminal emulators support mouse interaction. The Vty library used +by brick provides these low-level events if mouse mode has been enabled. +To enable mouse mode, we need to get access to the Vty library handle in +``EventM``: + +.. code:: haskell + + do + vty <- Brick.Main.getVtyHandle + let output = outputIface vty + when (supportsMode output Mouse) $ + liftIO $ setMode output Mouse True + +Bear in mind that some terminals do not support mouse interaction, so +use Vty's ``getModeStatus`` to find out whether your terminal will +provide mouse events. + +Also bear in mind that terminal users will usually expect to be able +to interact with your application entirely without a mouse, so if you +do choose to enable mouse interaction, consider using it to improve +existing interactions rather than provide new functionality that cannot +already be managed with a keyboard. + +Low-level Mouse Events +---------------------- + +Once mouse events have been enabled, Vty will generate ``EvMouseDown`` +and ``EvMouseUp`` events containing the mouse button clicked, the +location in the terminal, and any modifier keys pressed. + +.. code:: haskell + + handleEvent (VtyEvent (EvMouseDown col row button mods) = ... + +Brick Mouse Events +------------------ + +Although these events may be adequate for your needs, ``brick`` provides +a higher-level mouse event interface that ties into the drawing +language. The disadvantage to the low-level interface described above is +that you still need to determine *what* was clicked, i.e., the part of +the interface that was under the mouse cursor. There are two ways to do +this with ``brick``: with *click reporting* and *extent checking*. + +Click reporting +*************** + +The *click reporting* approach is the most high-level approach offered +by ``brick`` and the one that we recommend you use. In this approach, +we use ``Brick.Widgets.Core.clickable`` when drawing the interface to +request that a given widget generate ``MouseDown`` and ``MouseUp`` +events when it is clicked. + +.. code:: haskell + + data Name = MyButton + + ui :: Widget Name + ui = center $ + clickable MyButton $ + border $ + str "Click me" + + handleEvent (MouseDown MyButton button modifiers coords) = ... + handleEvent (MouseUp MyButton button coords) = ... + +This approach enables event handlers to use pattern matching to check +for mouse clicks on specific regions; this uses `Extent checking`_ +under the hood but makes it possible to denote which widgets are +clickable in the interface description. The event's click coordinates +are local to the widget being clicked. In the above example, a click +on the upper-left corner of the border would result in coordinates of +``(0,0)``. + +Extent checking +*************** + +The *extent checking* approach entails requesting extents (see +`Extents`_) for parts of your interface, then checking the Vty mouse +click event's coordinates against one or more extents. This approach +is slightly lower-level than the direct mouse click reporting approach +above but is provided in case you need more control over how mouse +clicks are dealt with. + +The most direct way to do this is to check a specific extent: + +.. code:: haskell + + handleEvent (VtyEvent (EvMouseDown col row _ _)) = do + mExtent <- lookupExtent SomeExtent + case mExtent of + Nothing -> return () + Just e -> do + if Brick.Main.clickedExtent (col, row) e + then ... + else ... + +This approach works well enough if you know which extent you're +interested in checking, but what if there are many extents and you +want to know which one was clicked? And what if those extents are in +different layers? The next approach is to find all clicked extents: + +.. code:: haskell + + handleEvent (VtyEvent (EvMouseDown col row _ _)) = do + extents <- Brick.Main.findClickedExtents (col, row) + -- Then check to see if a specific extent is in the list, or just + -- take the first one in the list. + +This approach finds all clicked extents and returns them in a list with +the following properties: + +* For extents ``A`` and ``B``, if ``A``'s layer is higher than ``B``'s + layer, ``A`` comes before ``B`` in the list. +* 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. + +As a result, the extents are ordered in a natural way, starting with the +most specific extents and proceeding to the most general. + +Viewports +========= + +A *viewport* is a scrollable window onto a widget. Viewports have a +*scrolling direction* of type ``Brick.Types.ViewportType`` which can be +one of: + +* ``Horizontal``: the viewport can only scroll horizontally. +* ``Vertical``: the viewport can only scroll vertically. +* ``Both``: the viewport can scroll both horizontally and vertically. + +The ``Brick.Widgets.Core.viewport`` combinator takes another widget +and embeds it in a named viewport. We name the viewport so that we can +keep track of its scrolling state in the renderer, and so that you can +make scrolling requests. The viewport's name is its handle for these +operations (see `Scrolling Viewports in Event Handlers`_ and `Resource +Names`_). **The viewport name must be unique across your application.** + +For example, the following puts a string in a horizontally-scrollable +viewport: + +.. code:: haskell + + -- Assuming that App uses 'Name' for its resource names: + data Name = Viewport1 + let w = viewport Viewport1 Horizontal $ str "Hello, world!" + +A ``viewport`` specification means that the widget in the viewport will +be placed in a viewport window that is ``Greedy`` in both directions +(see `Available Rendering Area`_). This is suitable if we want the +viewport size to be the size of the entire terminal window, but if +we want to limit the size of the viewport, we might use limiting +combinators (see `Limiting Rendering Area`_): + +.. code:: haskell + + let w = hLimit 5 $ + vLimit 1 $ + viewport Viewport1 Horizontal $ str "Hello, world!" + +Now the example produces a scrollable window one row high and five +columns wide initially showing "Hello". The next two sections discuss +the two ways in which this viewport can be scrolled. + +Scrolling Viewports in Event Handlers +------------------------------------- + +The most direct way to scroll a viewport is to make *scrolling requests* +in the ``EventM`` event-handling monad. Scrolling requests ask the +renderer to update the state of a viewport the next time the user +interface is rendered. Those state updates will be made with respect +to the *previous* viewport state, i.e., the state of the viewports as +of the end of the most recent rendering. This approach is the best +approach to use to scroll widgets that have no notion of a cursor. +For cursor-based scrolling, see `Scrolling Viewports With Visibility +Requests`_. + +To make scrolling requests, we first create a +``Brick.Main.ViewportScroll`` from a viewport name with +``Brick.Main.viewportScroll``: + +.. code:: haskell + + -- Assuming that App uses 'Name' for its resource names: + data Name = Viewport1 + let vp = viewportScroll Viewport1 + +The ``ViewportScroll`` record type contains a number of scrolling +functions for making scrolling requests: + +.. code:: haskell + + hScrollPage :: Direction -> EventM n s () + hScrollBy :: Int -> EventM n s () + hScrollToBeginning :: EventM n s () + hScrollToEnd :: EventM n s () + vScrollPage :: Direction -> EventM n s () + vScrollBy :: Int -> EventM n s () + vScrollToBeginning :: EventM n s () + vScrollToEnd :: EventM n s () + +In each case the scrolling function scrolls the viewport by the +specified amount in the specified direction; functions prefixed with +``h`` scroll horizontally and functions prefixed with ``v`` scroll +vertically. + +Scrolling operations do nothing when they don't make sense for the +specified viewport; scrolling a ``Vertical`` viewport horizontally is a +no-op, for example. + +Using ``viewportScroll`` we can write an event handler that scrolls the +``Viewport1`` viewport one column to the right: + +.. code:: haskell + + myHandler :: e -> EventM n s () + myHandler e = do + let vp = viewportScroll Viewport1 + hScrollBy vp 1 + +Scrolling Viewports With Visibility Requests +-------------------------------------------- + +When we need to scroll widgets only when a cursor in the viewport +leaves the viewport's bounds, we need to use *visibility requests*. A +visibility request is a hint to the renderer that some element of a +widget inside a viewport should be made visible, i.e., that the viewport +should be scrolled to bring the requested element into view. + +To use a visibility request to make a widget in a viewport visible, we +simply wrap it with ``visible``: + +.. code:: haskell + + -- Assuming that App uses 'Name' for its resource names: + data Name = Viewport1 + let w = viewport Viewport1 Horizontal $ + (visible $ str "Hello,") <+> (str " world!") + +This example requests that the ``Viewport1`` viewport be scrolled so +that "Hello," is visible. We could extend this example with a value +in the application state indicating which word in our string should +be visible and then use that to change which string gets wrapped with +``visible``; this is the basis of cursor-based scrolling. + +Note that a visibility request does not change the state of a viewport +*if the requested widget is already visible*! This important detail is +what makes visibility requests so powerful, because they can be used to +capture various cursor-based scenarios: + +* The ``Brick.Widgets.Edit`` widget uses a visibility request to make its + 1x1 cursor position visible, thus making the text editing widget fully + scrollable *while being entirely scrolling-unaware*. +* The ``Brick.Widgets.List`` widget uses a visibility request to make + its selected item visible regardless of its size, which makes + the list widget scrolling-unaware. + +Showing Scroll Bars on Viewports +-------------------------------- + +Brick supports drawing both vertical and horizontal scroll bars on +viewports. To enable scroll bars, wrap your call to ``viewport`` with +a call to ``withVScrollBars`` and/or ``withHScrollBars``. If you don't +like the appearance of the resulting scroll bars, 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. + +Scroll bars can also be configured to draw "handles" with +``withHScrollBarHandles`` and ``withVScrollBarHandles``. + +Lastly, scroll bars can be configured to report mouse events on +each scroll bar element. To enable mouse click reporting, use +``withClickableHScrollBars`` and ``withClickableVScrollBars``. + +For a demonstration of the scroll bar API in action, see the +``ViewportScrollbarsDemo.hs`` demonstration program. + +Viewport Restrictions +--------------------- + +Viewports impose one restriction: a viewport that is scrollable in +some direction can only embed a widget that has a ``Fixed`` size in +that direction. This extends to ``Both`` type viewports: they can only +embed widgets that are ``Fixed`` in both directions. This restriction +is because when viewports embed a widget, they relax the rendering area +constraint in the rendering context, but doing so to a large enough +number for ``Greedy`` widgets would result in a widget that is too big +and not scrollable in a useful way. + +Violating this restriction will result in a runtime exception. + +Input Forms +=========== + +While it's possible to construct interfaces with editors and other +interactive inputs manually, this process is somewhat tedious: all of +the event dispatching has to be written by hand, a focus ring or other +construct needs to be managed, and most of the rendering code needs to +be written. Furthermore, this process makes it difficult to follow some +common patterns: + +* We typically want to validate the user's input, and only collect it + once it has been validated. +* We typically want to notify the user when a particular field's + contents are invalid. +* It is often helpful to be able to create a new data type to represent + the fields in an input interface, and use it to initialize the input + elements and later collect the (validated) results. +* A lot of the rendering and event-handling work to be done is + repetitive. + +The ``Brick.Forms`` module provides a high-level API to automate all of +the above work in a type-safe manner. + +A Form Example +-------------- + +Let's consider an example data type that we'd want to use as the +basis for an input interface. This example comes directly from the +``FormDemo.hs`` demonstration program. + +.. code:: haskell + + data UserInfo = + FormState { _name :: T.Text + , _age :: Int + , _address :: T.Text + , _ridesBike :: Bool + , _handed :: Handedness + , _password :: T.Text + } deriving (Show) + + data Handedness = LeftHanded + | RightHanded + | Ambidextrous + deriving (Show, Eq) + +Suppose we want to build an input form for the above data. We might want +to use an editor to allow the user to enter a name and an age. We'll +need to ensure that the user's input for age is a valid integer. For +``_ridesBike`` we might want a checkbox-style input, and for ``_handed`` +we might want a radio button input. For ``_password``, we'd definitely +like a password input box that conceals the input. + +If we were to build an interface for this data manually, we'd need to +deal with converting the data above to the right types for inputs. For +example, for ``_age`` we'd need to convert an initial age value to +``Text``, put it in an editor with ``Brick.Widgets.Edit.editor``, and +then at a later time, parse the value and reconstruct an age from the +editor's contents. We'd also need to tell the user if the age value was +invalid. + +Brick's ``Forms`` API provides input field types for all of the above +use cases. Here's the form that we can use to allow the user to edit a +``UserInfo`` value: + +.. code:: haskell + + mkForm :: UserInfo -> Form UserInfo e Name + mkForm = + newForm [ editTextField name NameField (Just 1) + , editTextField address AddressField (Just 3) + , editShowableField age AgeField + , editPasswordField password PasswordField + , radioField handed [ (LeftHanded, LeftHandField, "Left") + , (RightHanded, RightHandField, "Right") + , (Ambidextrous, AmbiField, "Both") + ] + , checkboxField ridesBike BikeField "Do you ride a bicycle?" + ] + +A form is represented using a ``Form s e n`` value and is parameterized +with some types: + +* ``s`` - the type of *form state* managed by the form (in this case + ``UserInfo``) +* ``e`` - the event type of the application (must match the event type + used with ``App``) +* ``n`` - the resource name type of the application (must match the + resource name type used with ``App``) + +First of all, the above code assumes we've derived lenses for +``UserInfo`` using ``Lens.Micro.TH.makeLenses``. Once we've done +that, each field that we specify in the form must provide a lens into +``UserInfo`` so that we can declare the particular field of ``UserInfo`` +that will be edited by the field. For example, to edit the ``_name`` +field we use the ``name`` lens to create a text field editor with +``editTextField``. All of the field constructors above are provided by +``Brick.Forms``. + +Each form field also needs a resource name (see `Resource Names`_). The +resource names are assigned to the individual form inputs so the form +can automatically track input focus and handle mouse click events. + +The form carries with it the value of ``UserInfo`` that reflects the +contents of the form. Whenever an input field in the form handles an +event, its contents are validated and rewritten to the form state (in +this case, a ``UserInfo`` record). + +The ``mkForm`` function takes a ``UserInfo`` value, which is really +just an argument to ``newForm``. This ``UserInfo`` value will be used +to initialize all of the form fields. Each form field will use the lens +provided to extract the initial value from the ``UserInfo`` record, +convert it into an appropriate state type for the field in question, and +later validate that state and convert it back into the appropriate type +for storage in ``UserInfo``. + +The form value itself -- of type ``Form`` -- must be stored in your +application state. You should only ever call ``newForm`` when you need +to initialize a totally new form. Once initialized, the form needs to be +kept around and updated by event handlers in order to work. + +For example, if the initial ``UserInfo`` value's ``_age`` field has the +value ``0``, the ``editShowableField`` will call ``show`` on ``0``, +convert that to ``Text``, and initialize the editor for ``_age`` with +the text string ``"0"``. Later, if the user enters more text -- changing +the editor contents to ``"10"``, say -- the ``Read`` instance for +``Int`` (the type of ``_age``) will be used to parse ``"10"``. The +successfully-parsed value ``10`` will then be written to the ``_age`` +field of the form's ``UserInfo`` state using the ``age`` lens. The use +of ``Show`` and ``Read`` here is a feature of the field type we have +chosen for ``_age``, ``editShowableField``. + +For other field types we may have other needs. For instance, +``Handedness`` is a data type representing all the possible choices +we want to provide for a user's handedness. We wouldn't want the user +to have to type in a text string for this option. A more appropriate +input interface is a list of radio buttons to choose from amongst +the available options. For that we have ``radioField``. This field +constructor takes a list of all of the available options, and updates +the form state with the value of the currently-selected option. + +Rendering Forms +--------------- + +Rendering forms is done easily using the ``Brick.Forms.renderForm`` +function. However, as written above, the form will not look especially +nice. We'll see a few text editors followed by some radio buttons and a +check box. But we'll need to customize the output a bit to make the form +easier to use. For that, we have the ``Brick.Forms.@@=`` operator. This +operator lets us provide a function to augment the ``Widget`` generated +by the field's rendering function so we can do things like add labels, +control layout, or change attributes: + +.. code:: haskell + + (str "Name: " <+>) @@= + editTextField name NameField (Just 1) + +Now when we invoke ``renderForm`` on a form using the above example, +we'll see a ``"Name:"`` label to the left of the editor field for +the ``_name`` field of ``UserInfo``. + +Brick provides this interface to controlling per-field rendering because +many form fields either won't have labels or will have different layout +requirements, so an alternative API such as building the label into the +field API doesn't always make sense. + +Brick defaults to rendering individual fields' inputs, and the entire +form, in a vertical box using ``vBox``. Use ``setFormConcat`` and +``setFieldConcat`` to change this behavior to, e.g., ``hBox``. + +Form Attributes +--------------- + +The ``Brick.Forms`` module uses and exports two attribute names (see +`How Attributes Work`_): + +* ``focusedFormInputAttr`` - this attribute is used to render the form + field that has the focus. +* ``invalidFormInputAttr`` - this attribute is used to render any form + field that has user input that has invalid validation. + +Your application should set both of these. Some good mappings in the +attribute map are: + +* ``focusedFormInputAttr`` - ``black `on` yellow`` +* ``invalidFormInputAttr`` - ``white `on` red`` + +Handling Form Events +-------------------- + +Handling form events is easy: we just use ``zoom`` to call +``Brick.Forms.handleFormEvent`` with the ``BrickEvent`` and a lens +to access the ``Form`` in the application state. This automatically +dispatches input events to the currently-focused input field, and it +also manages focus changes with ``Tab`` and ``Shift-Tab`` keybindings. +(For details on all of its behaviors, see the Haddock documentation for +``handleFormEvent``.) It's still up to the application to decide when +events should go to the form in the first place. + +Since the form field handlers take ``BrickEvent`` values, that means +that custom fields could even handle application-specific events (of the +type ``e`` above). + +Once the application has decided that the user should be done with the +form editing session, the current state of the form can be obtained +with ``Brick.Forms.formState``. In the example above, this would +return a ``UserInfo`` record containing the values for each field in +the form *as of the last time it was valid input*. This means that +the user might have provided invalid input to a form field that is +not reflected in the form state due to failing validation. + +Since the ``formState`` is always a valid set of values, it might +be surprising to the user if the values used do not match the last +values they saw on the screen; the ``Brick.Forms.allFieldsValid`` +can be used to determine if the last visual state of the form had +any invalid entries and doesn't match the value of ``formState``. A +list of any fields which had invalid values can be retrieved with the +``Brick.Forms.invalidFields`` function. + +While each form field type provides a validator function to validate +its current user input value, that function is pure. As a result it's +not suitable for doing validation that requires I/O such as searching +a database or making network requests. If your application requires +that kind of validation, you can use the ``Brick.Forms.setFieldValid`` +function to set the validation state of any form field as you see +fit. The validation state set by that function will be considered by +``allFieldsValid`` and ``invalidFields``. See ``FormDemo.hs`` for an +example of this API. + +Note that if mouse events are enabled in your application (see `Mouse +Support`_), all built-in form fields will respond to mouse interaction. +Radio buttons and check boxes change selection on mouse clicks and +editors change cursor position on mouse clicks. + +Writing Custom Form Field Types +------------------------------- + +If the built-in form field types don't meet your needs, ``Brick.Forms`` +exposes all of the data types needed to implement your own field types. +For more details on how to do this, see the Haddock documentation for +the ``FormFieldState`` and ``FormField`` data types along with the +implementations of the built-in form field types. + +Customizable Keybindings +======================== + +Brick applications typically start out by explicitly checking incoming +events for specific keys in ``appHandleEvent``. While this works well +enough, it results in *tight coupling* between the input key events and +the event handlers that get run. As applications evolve, it becomes +important to decouple the input key events and their handlers to allow +the input keys to be customized by the user. That's where Brick's +customizable keybindings API comes in. + +The customizable keybindings API provides: + +* ``Brick.Keybindings.Parse``: parsing and loading user-provided + keybinding configuration files, +* ``Brick.Keybindings.Pretty``: pretty-printing keybindings and + generating keybinding help text in ``Widget``, plain text, and + Markdown formats so you can provide help to users both within the + program and outside of it, +* ``Brick.Keybindings.KeyEvents``: specifying the application's abstract + key events and their configuration names, +* ``Brick.Keybindings.KeyConfig``: bundling default and customized + keybindings for each abstract event into a structure for use by the + dispatcher, and +* ``Brick.Keybindings.KeyDispatcher``: specifying handlers and + dispatching incoming key events to them. + +This section of the User Guide describes the API at a high level, +but Brick also provides a complete working example of the custom +keybinding API in ``programs/CustomKeybindingDemo.hs`` and +provides detailed documentation on how to use the API, including a +step-by-step process for using it, in the module documentation for +``Brick.Keybindings.KeyDispatcher``. + +The following table compares Brick application design decisions and +runtime behaviors in a typical application to those of an application +that uses the customizable keybindings API: + ++---------------------+------------------------+-------------------------+ +| **Approach** | **Before runtime** | **At runtime** | ++---------------------+------------------------+-------------------------+ +| Typical application | The application author | #. An input event | +| (no custom | decides which keys will| arrives when the user| +| keybindings) | trigger application | presses a key. | +| | behaviors. The event | #. The event handler | +| | handler is written to | pattern-matches on | +| | pattern-match on | the input event to | +| | specific keys. | check for a match and| +| | | then runs the | +| | | corresponding | +| | | handler. | ++---------------------+------------------------+-------------------------+ +| Application with | The application author | #. A Vty input event | +| custom keybindings | specifies the possible | arrives when the user| +| API integrated | *abstract events* that | presses a key. | +| | correspond to the | #. The input event is | +| | application's | provided to | +| | behaviors. The events | ``appHandleEvent``. | +| | are given default | #. ``appHandleEvent`` | +| | keybindings. The | passes the event on | +| | application provides | to a | +| | event handlers for the | ``KeyDispatcher``. | +| | abstract events, not | #. The key dispatcher | +| | specific keys. If | checks to see whether| +| | desired, the | the input key event | +| | application can load | maps to an abstract | +| | user-defined custom | event. | +| | keybindings from an INI| #. If the dispatcher | +| | file at startup to | finds a match, the | +| | override the | corresponding | +| | application's defaults.| abstract event's key | +| | | handler is run. | ++---------------------+------------------------+-------------------------+ + +Keybinding Collisions +--------------------- + +An important issue to consider in using the custom keybinding API is +that it is possible for the user to map the same key to more than one +event. We refer to this situation as a *keybinding collision*. Whether +the collision represents a problem depends on how the events in question +are going to be handled by the application. This section provides an +example scenario and describes a way to deal with this situation. + +Suppose an application has two key events: + +.. code:: haskell + + data KeyEvent = QuitEvent + | CloseWindowEvent + + allKeyEvents :: KeyEvents KeyEvent + allKeyEvents = + K.keyEvents [ ("quit", QuitEvent) + , ("close-window", CloseWindowEvent) + ] + + defaultBindings :: [(KeyEvent, [Binding])] + defaultBindings = + [ (QuitEvent, [ctrl 'q']) + , (CloseWindowEvent, [bind KEsc]) + ] + +Suppose also that the application using the above key events has a +feature that opens a window, and that ``CloseWindowEvent`` is used to +close the window, while ``QuitEvent`` is used to quit the application. + +A user might then provide a custom INI file to rebind keys as follows:: + + [keybindings] + quit = Esc + close-window = Esc + +While this is a valid configuration for the user to provide, it would +result in a keybinding collision for ``Esc`` since it is now bound +to two events. Whether that's a problem depends entirely on how +``QuitEvent`` and ``CloseWindowEvent`` are handled: + +* If the application handles both events in the same event handler, + the ``KeyDispatcher`` for those events would fail to construct since + ``Esc`` maps to more than one event. Building a ``KeyDispatcher`` + from a ``KeyConfig`` with such a collision would fail and return + information about the collisions. +* If the application handles the two events in different dispatchers + then the collision has no effect and is not a problem since different + ``KeyDispatcher`` values would be constructed to handle the events + separately. This could happen, for instance, if the application only + ever handled ``CloseWindowEvent`` when the window in question was + 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 handling context. + +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 abstract event: + +.. code:: haskell + + K.onKey (K.bind '\t') "Increment the counter by 10" $ + counter %= (+ 10) + +If ``onKey`` is used, the handler it creates is only triggered by the +specified key (``Tab`` in the example above). But the handler may be +included alongside handlers in the same dispatcher that are *also* +triggered by ``Tab``, so if those event handlers were provided together +when creating a ``KeyDispatcher`` then it would fail to construct due to +the collision. + +Brick provides ``Brick.Keybindings.KeyConfig.keyEventMappings`` to help +finding collisions at the key configuration level. Finding out about +collisions at the dispatcher level is possible by handling the failure +case when calling ``Brick.Keybindings.KeyDispatcher.keyDispatcher``. + +Joining Borders +=============== + +Brick supports a feature called "joinable borders" which means that +borders drawn in adjacent widgets can be configured to automatically +"join" with each other using the appropriate intersection characters. +This feature is helpful for creating seamless connected borders without +the need for manual calculations to determine where to draw intersection +characters. + +Under normal circumstances, widgets are self-contained in that their +renderings do not interact with the appearance of adjacent widgets. This +is unfortunate for borders: one often wants to draw a T-shaped character +at the intersection of a vertical and horizontal border, for example. +To facilitate automatically adding such characters, ``brick`` offers +some border-specific capabilities for widgets to re-render themselves +as information about neighboring widgets becomes available during the +rendering process. + +Border-joining works by iteratively *redrawing* the edges of widgets as +those edges come into contact with other widgets during rendering. If +the adjacent edge locations of two widgets both use joinable borders, +the Brick will re-draw one of the characters so that it connects +seamlessly with the adjacent border. + +How Joining Works +----------------- + +When a widget is rendered, it can report supplementary information +about each position on its edges. Each position has four notional line +segments extending from its center, arranged like this: + +.. code:: text + + top + | + | + left ----+---- right + | + | + bottom + +These segments can independently be *drawn*, *accepting*, and +*offering*, as captured in the ``Brick.Types.BorderSegment`` type: + +.. code:: haskell + + data BorderSegment = BorderSegment + { bsAccept :: Bool + , bsOffer :: Bool + , bsDraw :: Bool + } + +If no information is reported for a position, it assumed that it is +not drawn, not accepting, and not offering -- and so it will never +be rewritten. This situation is the ordinary situation where an edge +location is not a border at all, or is a border that we don't want to +join to other borders. + +Line segments that are *drawn* are used for deciding which part of the +``BorderStyle`` to use if this position needs to be updated. (See also +`The Active Border Style`_.) For example, suppose a position needs to +be redrawn, and already has the left and bottom segments drawn; then it +will replace the current character with the upper-right corner drawing +character ``bsCornerTR`` from its border style. + +The *accepting* and *offering* properties are used to perform a small +handshake between neighboring widgets; when the handshake is successful, +one segment will transition to being drawn. For example, suppose a +horizontal and vertical border widget are drawn next to each other: + +.. code:: text + + top + (offering) top + | + | + left + right left ----+---- right + | (offering) (offering) + | + bottom bottom + (offering) + +These borders are accepting in all directions, drawn in the directions +signified by visible lines, and offering in the directions written. +Since the horizontal border on the right is offering towards the +vertical border, and the vertical border is accepting from the direction +towards the horizontal border, the right segment of the vertical +border will transition to being drawn. This will trigger an update of +the ``Image`` associated with the left widget, overwriting whatever +character is there currently with a ``bsIntersectL`` character instead. +The state of the segments afterwards will be the same, but the fact that +there is one more segment drawn will be recorded: + +.. code:: text + + top + (offering) top + | + | + left +---- right left ----+---- right + | (offering) (offering) + | + bottom bottom + (offering) + +It is important that this be recorded: we may later place this combined +widget to the right of another horizontal border, in which case we +would want to transition again from a ``bsIntersectL`` character to a +``bsIntersectFull`` character that represents all four segments being +drawn. + +Because this involves an interaction between multiple widgets, we +may find that the two widgets involved were rendered under different +rendering contexts. To avoid mixing and matching border styles and +drawing attributes, each location records not just the state of its +four segments but also the border style and attribute that were active +at the time the border was drawn. This information is stored in +``Brick.Types.DynBorder``. + +.. code:: haskell + + data DynBorder = DynBorder + { dbStyle :: BorderStyle + , dbAttr :: Attr + , dbSegments :: Edges BorderSegment + } + +The ``Brick.Types.Edges`` type has one field for each direction: + +.. code:: haskell + + data Edges a = Edges { eTop, eBottom, eLeft, eRight :: a } + +In addition to the offer/accept handshake described above, segments also +check that their neighbor's ``BorderStyle`` and ``Attr`` match their own +before transitioning from undrawn to drawn to avoid visual glitches from +trying to connect e.g. ``unicode`` borders to ``ascii`` ones or green +borders to red ones. + +The above description applies to a single location; any given widget's +result may report information about any location on its border using the +``Brick.BorderMap.BorderMap`` type. A ``BorderMap a`` is close kin to a +``Data.Map.Map Location a`` except that each ``BorderMap`` has a fixed +rectangle on which keys are retained. Values inserted at other keys are +silently discarded. + +For backwards compatibility, all the widgets that ship with ``brick`` +avoid reporting any border information by default, but ``brick`` offers +three ways of modifying the border-joining behavior of a widget. + +* ``Brick.Widgets.Core.joinBorders`` instructs any borders drawn in its + child widget to report their edge information. It does this + by setting a flag in the rendering context that tells the + ``Brick.Widgets.Border`` widgets to report the information described + above. Consequently, widgets drawn in this context will join their + borders with neighbors. +* ``Brick.Widgets.Core.separateBorders`` does the opposite of + ``joinBorders`` by unsetting the same context flag, preventing border + widgets from attempting to connect. +* ``Brick.Widgets.Core.freezeBorders`` lets its child widget connect its + borders internally but prevents it from connecting with anything + outside the ``freezeBorders`` call. It does this by deleting the edge + metadata about its child widget. This means that any connections + already made within the child widget will stay as they are but no new + connections will be made to adjacent widgets. For example, one might + use this to create a box with internal but no external connections: + + .. code:: haskell + + joinBorders . freezeBorders . border . hBox $ + [str "left", vBorder, str "right"] + + Or to create a box that allows external connections but not internal + ones: + + .. code:: haskell + + joinBorders . border . freezeBorders . hBox $ + [str "left", vBorder, str "right"] + +When creating new widgets, if you would like ``joinBorders`` and +``separateBorders`` to affect the behavior of your widget, you may do +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 +=================== + +When widgets become expensive to render, ``brick`` provides a *rendering +cache* that automatically caches and re-uses stored Vty images from +previous renderings to avoid expensive renderings. To cache the +rendering of a widget, just wrap it in the ``Brick.Widgets.Core.cached`` +function: + +.. code:: haskell + + data Name = ExpensiveThing + + ui :: Widget Name + ui = center $ + cached ExpensiveThing $ + 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 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 +more sophisticated widgets might. + +Once ``cached`` has been used to store something in the rendering cache, +periodic cache invalidation may be required. For example, if the cached +widget is built from application state, the cache will need to be +invalidated when the relevant state changes. The cache may also need to +be invalidated when the terminal is resized. To invalidate the cache, we +use the cache invalidation functions in ``EventM``: + +.. code:: haskell + + handleEvent ... = do + -- Invalidate just a single cache entry: + Brick.Main.invalidateCacheEntry ExpensiveThing + + -- Invalidate the entire cache (useful on a resize): + Brick.Main.invalidateCache + +Implementing Custom Widgets +=========================== + +``brick`` exposes all of the internals you need to implement your +own widgets. Those internals, together with ``Graphics.Vty``, can be +used to create widgets from the ground up. You'll need to implement +your own widget if you can't write what you need in terms of existing +combinators. For example, an ordinary widget like + +.. code:: haskell + + myWidget :: Widget n + myWidget = str "Above" <=> str "Below" + +can be expressed with ``<=>`` and ``str`` and needs no custom behavior. +But suppose we want to write a widget that renders some string followed +by the number of columns in the space available to the widget. We can't +do this without writing a custom widget because we need access to the +rendering context. We can write such a widget as follows: + +.. code:: haskell + + customWidget :: String -> Widget n + customWidget s = + Widget Fixed Fixed $ do + ctx <- getContext + render $ str (s <> " " <> show (ctx^.availWidthL)) + +The ``Widget`` constructor takes the horizontal and vertical growth +policies as described in `How Widgets and Rendering Work`_. Here we just +provide ``Fixed`` for both because the widget will not change behavior +if we give it more space. We then get the rendering context and append +the context's available columns to the provided string. Lastly we call +``render`` to render the widget we made with ``str``. The ``render`` +function returns a ``Brick.Types.Result`` value: + +.. code:: haskell + + data Result n = + Result { image :: Graphics.Vty.Image + , cursors :: [Brick.Types.CursorLocation n] + , visibilityRequests :: [Brick.Types.VisibilityRequest] + , extents :: [Extent n] + , borders :: BorderMap DynBorder + } + +The rendering function runs in the ``RenderM`` monad, which gives us +access to the rendering context (see `How Widgets and Rendering Work`_) +via the ``Brick.Types.getContext`` function as shown above. The context +tells us about the dimensions of the rendering area and the current +attribute state of the renderer, among other things: + +.. code:: haskell + + data Context = + Context { ctxAttrName :: AttrName + , availWidth :: Int + , availHeight :: Int + , ctxBorderStyle :: BorderStyle + , ctxAttrMap :: AttrMap + , ctxDynBorders :: Bool + } + +and has lens fields exported as described in `Conventions`_. + +As shown here, the job of the rendering function is to return a +rendering result which means producing a ``vty`` ``Image``. In addition, +if you so choose, you can also return one or more cursor positions in +the ``cursors`` field of the ``Result`` as well as visibility requests +(see `Viewports`_) in the ``visibilityRequests`` field. Returned +visibility requests and cursor positions should be relative to the +upper-left corner of your widget, ``Location (0, 0)``. When your widget +is placed in others, such as boxes, the ``Result`` data you returned +will be offset (as described in `Rendering Sub-Widgets`_) to result in +correct coordinates once the entire interface has been rendered. + +Using the Rendering Context +--------------------------- + +The most important fields of the context are the rendering area fields +``availWidth`` and ``availHeight``. These fields must be used to +determine how much space your widget has to render. + +To perform an attribute lookup in the attribute map for the context's +current attribute, use ``Brick.Types.attrL``. + +For example, to build a widget that always fills the available width and +height with a fill character using the current attribute, we could +write: + +.. code:: haskell + + myFill :: Char -> Widget n + myFill ch = + Widget Greedy Greedy $ do + ctx <- getContext + let a = ctx^.attrL + return $ Result (Graphics.Vty.charFill a ch (ctx^.availWidthL) (ctx^.availHeightL)) + [] [] [] Brick.BorderMap.empty + +Rendering Sub-Widgets +--------------------- + +If your custom widget wraps another, then in addition to rendering +the wrapped widget and augmenting its returned ``Result`` *it must +also translate the resulting cursor locations, visibility requests, +and extents*. This is vital to maintaining the correctness of +rendering metadata as widget layout proceeds. To do so, use the +``Brick.Widgets.Core.addResultOffset`` function to offset the elements +of a ``Result`` by a specified amount. The amount depends on the nature +of the offset introduced by your wrapper widget's logic. + +Widgets are not required to respect the rendering context's width and +height restrictions. Widgets may be embedded in viewports or translated +so they must render without cropping to work in those scenarios. +However, widgets rendering other widgets *should* enforce the rendering +context's constraints to avoid using more space than is available. The +``Brick.Widgets.Core.cropToContext`` function is provided to make this +easy: + +.. code:: haskell + + let w = cropToContext someWidget + +Widgets wrapped with ``cropToContext`` can be safely embedded in other +widgets. If you don't want to crop in this way, you can use any of +``vty``'s cropping functions to operate on the ``Result`` image as +desired. + +Sub-widgets may specify specific attribute name values influencing +that sub-widget. If the custom widget utilizes its own attribute +names but needs to render the sub-widget, it can use ``overrideAttr`` +or ``mapAttrNames`` to convert its custom names to the names that the +sub-widget uses for rendering its output. + +.. _vty: https://github.com/jtdaugherty/vty +.. _Hackage: http://hackage.haskell.org/ +.. _microlens: http://hackage.haskell.org/package/microlens +.. _bracketed paste mode: https://cirw.in/blog/bracketed-paste diff --git a/docs/snake-demo.gif b/docs/snake-demo.gif new file mode 100644 Binary files /dev/null and b/docs/snake-demo.gif differ diff --git a/programs/AnimationDemo.hs b/programs/AnimationDemo.hs new file mode 100644 --- /dev/null +++ b/programs/AnimationDemo.hs @@ -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, translateBy, 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) = + translateBy 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 diff --git a/programs/AttrDemo.hs b/programs/AttrDemo.hs --- a/programs/AttrDemo.hs +++ b/programs/AttrDemo.hs @@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Main where +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid +#endif import Graphics.Vty - ( Event, Attr, white, blue, cyan, green, red, yellow - , black + ( Attr, white, blue, cyan, green, red, yellow + , black, withURL ) import Brick.Main @@ -16,28 +19,39 @@ , withAttr , vBox , str + , hyperlink + , modifyDefAttr ) import Brick.Util (on, fg) -import Brick.AttrMap (attrMap, AttrMap) +import Brick.AttrMap (attrMap, AttrMap, attrName) -ui :: Widget +ui :: Widget n ui = vBox [ str "This text uses the global default attribute." - , withAttr "foundFull" $ + , withAttr (attrName "foundFull") $ str "Specifying an attribute name means we look it up in the attribute tree." - , (withAttr "foundFgOnly" $ - str ("When we find a value, we merge it with its parent in the attribute") - <=> str "name tree all the way to the root (the global default).") - , withAttr "missing" $ + , withAttr (attrName "foundFgOnly") $ + str "When we find a value, we merge it with its parent in the attribute" + <=> str "name tree all the way to the root (the global default)." + , withAttr (attrName "missing") $ str "A missing attribute name just resumes the search at its parent." - , withAttr ("general" <> "specific") $ + , withAttr (attrName "general" <> attrName "specific") $ str "In this way we build complete attribute values by using an inheritance scheme." - , withAttr "foundFull" $ + , withAttr (attrName "foundFull") $ str "You can override everything ..." - , withAttr "foundFgOnly" $ - str "... or only you want to change and inherit the rest." + , withAttr (attrName "foundFgOnly") $ + str "... or only what you want to change and inherit the rest." , str "Attribute names are assembled with the Monoid append operation to indicate" - , str "hierarchy levels, e.g. \"window\" <> \"title\"." + , str "hierarchy levels, e.g. attrName \"window\" <> attrName \"title\"." + , str " " + , withAttr (attrName "linked") $ + str "This text is hyperlinked in terminals that support hyperlinking." + , str " " + , hyperlink "http://www.google.com/" $ + str "This text is also hyperlinked in terminals that support hyperlinking." + , str " " + , modifyDefAttr (`withURL` "http://www.google.com/") $ + str "This text is hyperlinked by modifying the default attribute." ] globalDefault :: Attr @@ -45,20 +59,21 @@ theMap :: AttrMap theMap = attrMap globalDefault - [ ("foundFull", white `on` green) - , ("foundFgOnly", fg red) - , ("general", yellow `on` black) - , ("general" <> "specific", fg cyan) + [ (attrName "foundFull", white `on` green) + , (attrName "foundFgOnly", fg red) + , (attrName "general", yellow `on` black) + , (attrName "general" <> attrName "specific", + fg cyan) + , (attrName "linked", fg yellow `withURL` "http://www.google.com/") ] -app :: App () Event +app :: App () e () app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const theMap , appChooseCursor = neverShowCursor - , appLiftVtyEvent = id } main :: IO () diff --git a/programs/BorderDemo.hs b/programs/BorderDemo.hs --- a/programs/BorderDemo.hs +++ b/programs/BorderDemo.hs @@ -1,27 +1,32 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Applicative ((<$>)) -import Data.Monoid +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif + import qualified Data.Text as T import qualified Graphics.Vty as V import qualified Brick.Main as M -import Brick.Util (fg, bg, on) +import Brick.Util (fg, on) import qualified Brick.AttrMap as A import Brick.Types ( 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 @@ -52,47 +57,48 @@ , BS.bsVertical = '!' } -borderDemos :: [Widget] +borderDemos :: [Widget ()] borderDemos = mkBorderDemo <$> styles -mkBorderDemo :: (T.Text, BS.BorderStyle) -> Widget +mkBorderDemo :: (T.Text, BS.BorderStyle) -> Widget () mkBorderDemo (styleName, sty) = withBorderStyle sty $ B.borderWithLabel (str "label") $ vLimit 5 $ C.vCenter $ - txt $ " " <> styleName <> " style " + padLeftRight 2 $ + txt $ styleName <> " style" -borderMappings :: [(A.AttrName, V.Attr)] -borderMappings = +titleAttr :: A.AttrName +titleAttr = A.attrName "title" + +attrs :: [(A.AttrName, V.Attr)] +attrs = [ (B.borderAttr, V.yellow `on` V.black) - , (B.vBorderAttr, V.green `on` V.red) - , (B.hBorderAttr, V.white `on` V.green) - , (B.hBorderLabelAttr, fg V.blue) - , (B.tlCornerAttr, bg V.red) - , (B.trCornerAttr, bg V.blue) - , (B.blCornerAttr, bg V.yellow) - , (B.brCornerAttr, bg V.green) + , (B.vBorderAttr, fg V.cyan) + , (B.hBorderAttr, fg V.magenta) + , (titleAttr, fg V.cyan) ] -colorDemo :: Widget +colorDemo :: Widget () colorDemo = - updateAttrMap (A.applyAttrMappings borderMappings) $ - B.borderWithLabel (str "title") $ + updateAttrMap (A.applyAttrMappings attrs) $ + B.borderWithLabel (withAttr titleAttr $ str "title") $ hLimit 20 $ vLimit 5 $ C.center $ str "colors!" -ui :: Widget +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 diff --git a/programs/CacheDemo.hs b/programs/CacheDemo.hs new file mode 100644 --- /dev/null +++ b/programs/CacheDemo.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Control.Monad (void) +import Control.Monad.State (modify) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Graphics.Vty as V + +import qualified Brick.Types as T +import qualified Brick.Main as M +import qualified Brick.Widgets.Center as C +import Brick.Types + ( Widget + , BrickEvent(..) + ) +import Brick.Widgets.Core + ( Padding(..) + , vBox + , padTopBottom + , withDefAttr + , cached + , padBottom + , str + ) +import Brick (on) +import Brick.Widgets.Center + ( hCenter + ) +import Brick.AttrMap + ( AttrName + , attrName + , attrMap + ) + +data Name = ExpensiveWidget + deriving (Ord, Show, Eq) + +drawUi :: Int -> [Widget Name] +drawUi i = [ui] + where + ui = C.vCenter $ + vBox $ hCenter <$> + [ str "This demo shows how cached widgets behave. The top widget below" + , str "is cacheable, so once it's rendered, brick re-uses the rendering" + , str "each time it is drawn. The bottom widget is not cacheable so it is" + , str "drawn on every request. Brick supports cache invalidation to force" + , str "a redraw of cached widgets; we can trigger that here with 'i'. Notice" + , str "how state changes with '+' aren't reflected in the cached widget" + , str "until the cache is invalidated with 'i'." + , padTopBottom 1 $ + cached ExpensiveWidget $ + withDefAttr emphAttr $ str $ "This widget is cached (state = " <> show i <> ")" + , padBottom (Pad 1) $ + withDefAttr emphAttr $ str $ "This widget is not cached (state = " <> show i <> ")" + , hCenter $ str "Press 'i' to invalidate the cache," + , str "'+' to change the state value, and" + , str "'Esc' to quit." + ] + +appEvent :: BrickEvent Name e -> T.EventM Name Int () +appEvent (VtyEvent (V.EvKey (V.KChar '+') [])) = modify (+ 1) +appEvent (VtyEvent (V.EvKey (V.KChar 'i') [])) = M.invalidateCacheEntry ExpensiveWidget +appEvent (VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () + +emphAttr :: AttrName +emphAttr = attrName "emphasis" + +app :: M.App Int e Name +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = return () + , M.appHandleEvent = appEvent + , M.appAttrMap = const $ attrMap V.defAttr [(emphAttr, V.white `on` V.blue)] + , M.appChooseCursor = M.neverShowCursor + } + +main :: IO () +main = void $ M.defaultMain app 0 diff --git a/programs/CroppingDemo.hs b/programs/CroppingDemo.hs new file mode 100644 --- /dev/null +++ b/programs/CroppingDemo.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) +import Brick.Types + ( Widget + ) +import Brick.Widgets.Core + ( vBox + , hBox + , txt + , (<=>) + , padRight + , cropLeftBy + , cropRightBy + , cropTopBy + , cropBottomBy + , cropLeftTo + , cropRightTo + , cropTopTo + , cropBottomTo + , Padding(..) + ) +import Brick.Widgets.Border (border) +import Brick.AttrMap (attrMap) +import qualified Graphics.Vty as V + +example :: Widget n +example = + border + (txt "Example" <=> txt "Widget") + +mkExample :: Widget n -> Widget n +mkExample = padRight (Pad 2) + +ui :: Widget () +ui = + vBox [ txt "Uncropped" <=> example + , hBox [ mkExample $ txt "cropLeftBy 2" <=> cropLeftBy 2 example + , mkExample $ txt "cropRightBy 2" <=> cropRightBy 2 example + , mkExample $ txt "cropTopBy 2" <=> cropTopBy 2 example + , mkExample $ txt "cropBottomBy 2" <=> cropBottomBy 2 example + ] + , hBox [ mkExample $ txt "cropLeftTo 4" <=> cropLeftTo 4 example + , mkExample $ txt "cropRightTo 4" <=> cropRightTo 4 example + , mkExample $ txt "cropTopTo 1" <=> cropTopTo 1 example + , mkExample $ txt "cropBottomTo 1" <=> cropBottomTo 1 example + ] + ] + +app :: App () e () +app = + App { appDraw = const [ui] + , appHandleEvent = resizeOrQuit + , appStartEvent = return () + , appAttrMap = const $ attrMap V.defAttr [] + , appChooseCursor = neverShowCursor + } + +main :: IO () +main = defaultMain app () diff --git a/programs/CustomEventDemo.hs b/programs/CustomEventDemo.hs --- a/programs/CustomEventDemo.hs +++ b/programs/CustomEventDemo.hs @@ -1,77 +1,86 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module Main where -import Control.Lens (makeLenses, (^.), (&), (.~), (%~)) +import Lens.Micro ((^.)) +import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void, forever) -import Control.Concurrent (newChan, writeChan, threadDelay, forkIO) -import Data.Default +import Control.Concurrent (threadDelay, forkIO) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid +#endif import qualified Graphics.Vty as V +import Brick.BChan import Brick.Main ( App(..) , showFirstCursor - , customMain - , continue + , customMainWithDefaultVty , halt ) +import Brick.AttrMap + ( attrMap + ) import Brick.Types ( Widget - , Next , EventM + , BrickEvent(..) ) import Brick.Widgets.Core ( (<=>) , str ) +data CustomEvent = Counter deriving Show + data St = - St { _stLastVtyEvent :: Maybe V.Event + St { _stLastBrickEvent :: Maybe (BrickEvent () CustomEvent) , _stCounter :: Int } makeLenses ''St -data CustomEvent = VtyEvent V.Event - | Counter - -drawUI :: St -> [Widget] +drawUI :: St -> [Widget ()] drawUI st = [a] where - a = (str $ "Last Vty event: " <> (show $ st^.stLastVtyEvent)) + a = (str $ "Last event: " <> (show $ st^.stLastBrickEvent)) <=> (str $ "Counter value is: " <> (show $ st^.stCounter)) -appEvent :: St -> CustomEvent -> EventM (Next St) -appEvent st e = +appEvent :: BrickEvent () CustomEvent -> EventM () St () +appEvent e = case e of - VtyEvent (V.EvKey V.KEsc []) -> halt st - VtyEvent ev -> continue $ st & stLastVtyEvent .~ (Just ev) - Counter -> continue $ st & stCounter %~ (+1) + VtyEvent (V.EvKey V.KEsc []) -> halt + VtyEvent _ -> stLastBrickEvent .= (Just e) + AppEvent Counter -> do + stCounter %= (+1) + stLastBrickEvent .= (Just e) + _ -> return () initialState :: St initialState = - St { _stLastVtyEvent = Nothing + St { _stLastBrickEvent = Nothing , _stCounter = 0 } -theApp :: App St CustomEvent +theApp :: App St CustomEvent () theApp = App { appDraw = drawUI , appChooseCursor = showFirstCursor , appHandleEvent = appEvent - , appStartEvent = return - , appAttrMap = def - , appLiftVtyEvent = VtyEvent + , appStartEvent = return () + , appAttrMap = const $ attrMap V.defAttr [] } main :: IO () main = do - chan <- newChan + chan <- newBChan 10 - forkIO $ forever $ do - writeChan chan Counter + void $ forkIO $ forever $ do + writeBChan chan Counter threadDelay 1000000 - void $ customMain (V.mkVty def) chan theApp initialState + (_, vty) <- customMainWithDefaultVty (Just chan) theApp initialState + V.shutdown vty diff --git a/programs/CustomKeybindingDemo.hs b/programs/CustomKeybindingDemo.hs new file mode 100644 --- /dev/null +++ b/programs/CustomKeybindingDemo.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Lens.Micro ((^.)) +import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl ((<~), (.=), (%=), use) +import Control.Monad (void, forM_, when) +import qualified Data.Set as S +import Data.Maybe (fromJust) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Graphics.Vty as V +import System.Environment (getArgs) +import System.Exit (exitFailure) + +import qualified Brick.Types as T +import Brick.Types (Widget) +import qualified Brick.Keybindings as K +import Brick.AttrMap +import Brick.Util (fg) +import qualified Brick.Main as M +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Center as C +import Brick.Widgets.Core + +-- | The abstract key events for the application. +data KeyEvent = QuitEvent + | IncrementEvent + | DecrementEvent + deriving (Ord, Eq, Show) + +-- | The mapping of key events to their configuration field names. +allKeyEvents :: K.KeyEvents KeyEvent +allKeyEvents = + K.keyEvents [ ("quit", QuitEvent) + , ("increment", IncrementEvent) + , ("decrement", DecrementEvent) + ] + +-- | Default key bindings for each abstract key event. +defaultBindings :: [(KeyEvent, [K.Binding])] +defaultBindings = + [ (QuitEvent, [K.ctrl 'q', K.bind V.KEsc]) + , (IncrementEvent, [K.bind '+']) + , (DecrementEvent, [K.bind '-']) + ] + +data St = + St { _keyConfig :: K.KeyConfig KeyEvent + -- ^ The key config to use. + , _lastKey :: Maybe (V.Key, [V.Modifier]) + -- ^ The last key that was pressed. + , _lastKeyHandled :: Bool + -- ^ Whether the last key was handled by a handler. + , _counter :: Int + -- ^ The counter value to manipulate in the handlers. + , _customBindingsPath :: Maybe FilePath + -- ^ Set if the application found custom keybindings in the + -- specified file. + , _dispatcher :: K.KeyDispatcher KeyEvent (T.EventM () St) + -- ^ The key dispatcher we'll use to dispatch input events. + } + +makeLenses ''St + +-- | Key event handlers for our application. +handlers :: [K.KeyEventHandler KeyEvent (T.EventM () St)] +handlers = + -- The first three handlers are triggered by keys mapped to abstract + -- events, thus decoupling the configured key bindings from these + -- handlers. + [ K.onEvent QuitEvent "Quit the program" + M.halt + , K.onEvent IncrementEvent "Increment the counter" $ + counter %= succ + , K.onEvent DecrementEvent "Decrement the counter" $ + counter %= subtract 1 + + -- These handlers are always triggered by specific keys and thus + -- cannot be rebound. + , K.onKey (K.bind '\t') "Increment the counter by 10" $ + counter %= (+ 10) + , K.onKey (K.bind V.KBackTab) "Decrement the counter by 10" $ + counter %= subtract 10 + ] + +appEvent :: T.BrickEvent () e -> T.EventM () St () +appEvent (T.VtyEvent (V.EvKey k mods)) = do + -- Dispatch the key to the event handler to which the key is mapped, + -- if any. Also record in lastKeyHandled whether the dispatcher + -- found a matching handler. + d <- use dispatcher + lastKey .= Just (k, mods) + lastKeyHandled <~ K.handleKey d k mods +appEvent _ = + return () + +drawUi :: St -> [Widget ()] +drawUi st = [body] + where + binding = uncurry K.binding <$> st^.lastKey + + -- Generate key binding help using the library so we can embed + -- it in the UI. + keybindingHelp = B.borderWithLabel (txt "Active Keybindings") $ + K.keybindingHelpWidget (st^.keyConfig) handlers + + lastKeyDisplay = withDefAttr lastKeyAttr $ + txt $ maybe "(none)" K.ppBinding binding + + -- Show the status of the last pressed key, whether we handled + -- it, and other bits of the application state. + status = B.borderWithLabel (txt "Status") $ + hLimit 40 $ + padRight Max $ + vBox [ txt "Last key: " <+> lastKeyDisplay + , str $ "Last key handled: " <> show (st^.lastKeyHandled) + , str $ "Counter: " <> show (st^.counter) + ] + + -- Show info about whether the application is currently using + -- custom bindings loaded from an INI file. + customBindingInfo = + B.borderWithLabel (txt "Custom Bindings") $ + case st^.customBindingsPath of + Nothing -> + hLimit 40 $ + txtWrap $ "No custom bindings loaded. Create an INI file with a " <> + (Text.pack $ show sectionName) <> + " section or use 'programs/custom_keys.ini'. " <> + "Pass its path to this program on the command line." + Just f -> str "Loaded custom bindings from:" <=> str (show f) + + body = C.center $ + (padRight (Pad 2) $ status <=> customBindingInfo) <+> + keybindingHelp + +lastKeyAttr :: AttrName +lastKeyAttr = attrName "lastKey" + +app :: M.App St e () +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = return () + , M.appHandleEvent = appEvent + , M.appAttrMap = const $ attrMap V.defAttr [ (K.eventNameAttr, fg V.magenta) + , (K.eventDescriptionAttr, fg V.cyan) + , (K.keybindingAttr, fg V.yellow) + , (lastKeyAttr, fg V.white `V.withStyle` V.bold) + ] + , M.appChooseCursor = M.showFirstCursor + } + +sectionName :: Text.Text +sectionName = "keybindings" + +main :: IO () +main = do + args <- getArgs + + -- If the command line specified the path to an INI file with custom + -- bindings, attempt to load it. + (customBindings, customFile) <- case args of + [iniFilePath] -> do + result <- K.keybindingsFromFile allKeyEvents sectionName iniFilePath + case result of + -- A section was found and had zero more bindings. + Right (Just bindings) -> + return (bindings, Just iniFilePath) + + -- No section was found at all. + Right Nothing -> do + putStrLn $ "Error: found no section " <> show sectionName <> " in " <> show iniFilePath + exitFailure + + -- There was some problem parsing the file as an INI + -- file. + Left e -> do + putStrLn $ "Error reading keybindings file " <> show iniFilePath <> ": " <> e + exitFailure + + _ -> return ([], Nothing) + + -- Create a key config that includes the default bindings as well as + -- the custom bindings we loaded from the INI file, if any. + let kc = K.newKeyConfig allKeyEvents defaultBindings customBindings + + -- Before starting the application, check on whether any events have + -- colliding bindings. Exit if so. + -- + -- Note that in a Real Application, we would more than likely + -- want to check for collisions among specific sets of + -- events. For example, if 'Esc' was bound to both 'quit' and + -- 'close-dialog-box', we might not care about such a collision + -- if the application only ever handled the 'close-dialog-box' + -- event in a separate mode and only ever handled 'quit' at the + -- top-level of the event handler. But if we had two events such as + -- 'dialog-box-okay' and 'dialog-box-cancel' that were intended to + -- be handled in the same mode, we might want to check that those + -- two events did not have the same binding. + forM_ (K.keyEventMappings kc) $ \(b, evs) -> do + when (S.size evs > 1) $ do + Text.putStrLn $ "Error: key '" <> K.ppBinding b <> "' is bound to multiple events:" + forM_ evs $ \e -> + Text.putStrLn $ " " <> Text.pack (show e) <> " (" <> fromJust (K.keyEventName allKeyEvents e) <> ")" + exitFailure + + -- Now 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 { _keyConfig = kc + , _lastKey = Nothing + , _lastKeyHandled = False + , _counter = 0 + , _customBindingsPath = customFile + , _dispatcher = d + } + + -- Now demonstrate how the library's generated key binding help text + -- looks in plain text and Markdown formats. These can be used to + -- generate documentation for users. Note that the output generated + -- here takes the active bindings into account! If you don't want + -- that, use a key config that doesn't have any custom bindings + -- applied. + let sections = [("Main", handlers)] + + putStrLn "Generated plain text help:" + Text.putStrLn $ K.keybindingTextTable kc sections + + putStrLn "Generated Markdown help:" + Text.putStrLn $ K.keybindingMarkdownTable kc sections diff --git a/programs/DialogDemo.hs b/programs/DialogDemo.hs --- a/programs/DialogDemo.hs +++ b/programs/DialogDemo.hs @@ -1,12 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Main where +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid +#endif import qualified Graphics.Vty as V import qualified Brick.Main as M import Brick.Types ( Widget + , BrickEvent(..) ) import Brick.Widgets.Core ( padAll @@ -21,24 +25,31 @@ data Choice = Red | Blue | Green deriving Show -drawUI :: D.Dialog Choice -> [Widget] +data Name = + RedButton + | BlueButton + | GreenButton + deriving (Show, Eq, Ord) + +drawUI :: D.Dialog Choice Name -> [Widget Name] drawUI d = [ui] where ui = D.renderDialog d $ C.hCenter $ padAll 1 $ str "This is the dialog body." -appEvent :: D.Dialog Choice -> V.Event -> T.EventM (T.Next (D.Dialog Choice)) -appEvent d ev = +appEvent :: BrickEvent Name e -> T.EventM Name (D.Dialog Choice Name) () +appEvent (VtyEvent ev) = case ev of - V.EvKey V.KEsc [] -> M.halt d - V.EvKey V.KEnter [] -> M.halt d - _ -> M.continue =<< T.handleEvent ev d + V.EvKey V.KEsc [] -> M.halt + V.EvKey V.KEnter [] -> M.halt + _ -> D.handleDialogEvent ev +appEvent _ = return () -initialState :: D.Dialog Choice -initialState = D.dialog "dialog" (Just "Title") (Just (0, choices)) 50 +initialState :: D.Dialog Choice Name +initialState = D.dialog (Just $ str "Title") (Just (RedButton, choices)) 50 where - choices = [ ("Red", Red) - , ("Blue", Blue) - , ("Green", Green) + choices = [ ("Red", RedButton, Red) + , ("Blue", BlueButton, Blue) + , ("Green", GreenButton, Green) ] theMap :: A.AttrMap @@ -48,14 +59,13 @@ , (D.buttonSelectedAttr, bg V.yellow) ] -theApp :: M.App (D.Dialog Choice) V.Event +theApp :: M.App (D.Dialog Choice Name) e Name theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap - , M.appLiftVtyEvent = id } main :: IO () diff --git a/programs/DynamicBorderDemo.hs b/programs/DynamicBorderDemo.hs new file mode 100644 --- /dev/null +++ b/programs/DynamicBorderDemo.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Brick.Main as M +import Brick.Types + ( Widget + ) +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Core as C +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Border.Style as BS + +doubleHorizontal :: BS.BorderStyle +doubleHorizontal = BS.BorderStyle + { BS.bsCornerTL = '╒' + , BS.bsCornerTR = '╕' + , BS.bsCornerBR = '╛' + , BS.bsCornerBL = '╘' + , BS.bsIntersectL = '╞' + , BS.bsIntersectR = '╡' + , BS.bsIntersectT = '╤' + , BS.bsIntersectB = '╧' + , BS.bsIntersectFull = '╪' + , BS.bsHorizontal = '═' + , BS.bsVertical = '│' + } + +box1 :: Widget () +box1 + = C.withBorderStyle doubleHorizontal . B.border + . C.withBorderStyle BS.unicodeRounded . B.border + $ C.str "25 kg" + +weights :: Widget () +weights = C.withBorderStyle doubleHorizontal $ C.hBox + [ box1 + , C.str "\n\n" C.<=> B.hBorder + , box1 + ] + +box2 :: Widget () +box2 = C.freezeBorders $ C.vBox + [ C.hBox + [ C.vLimit 3 B.vBorder + , C.str "Resize horizontally to\nmove across the label\nbelow" + , C.vLimit 3 B.vBorder + ] + , B.borderWithLabel (B.vBorder C.<+> C.str " Label " C.<+> B.vBorder) $ C.hBox + [ C.str " " + , C.vBox [B.vBorder, C.str "L\na\nb\ne\nl", C.vLimit 3 B.vBorder] + , C.str "\n\n\n Resize vertically to\n move across the label\n to the left\n\n\n\n\n" C.<=> B.hBorder + ] + ] + +-- BYOB: build your own border +byob :: Widget () +byob = C.vBox + [ C.hBox [ corner , top , corner ] + , C.vLimit 6 $ C.hBox [ B.vBorder, mid , B.vBorder] + , C.hBox [ corner , B.hBorder, corner ] + ] + where + top = B.hBorderWithLabel (C.str "BYOB") + mid = C.center (C.str "If `border` is too easy,\nyou can build it yourself") + corner = B.joinableBorder (pure False) + +ui :: Widget () +ui = C.vBox [weights, box2, byob] + +main :: IO () +main = M.simpleMain (C.joinBorders ui) diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs --- a/programs/EditDemo.hs +++ b/programs/EditDemo.hs @@ -3,7 +3,9 @@ {-# LANGUAGE RankNTypes #-} module Main where -import Control.Lens +import Lens.Micro +import Lens.Micro.TH +import Lens.Micro.Mtl import qualified Graphics.Vty as V import qualified Brick.Main as M @@ -18,72 +20,70 @@ import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Edit as E import qualified Brick.AttrMap as A +import qualified Brick.Focus as F import Brick.Util (on) +data Name = Edit1 + | Edit2 + deriving (Ord, Show, Eq) + data St = - St { _currentEditor :: T.Name - , _edit1 :: E.Editor - , _edit2 :: E.Editor + St { _focusRing :: F.FocusRing Name + , _edit1 :: E.Editor String Name + , _edit2 :: E.Editor String Name } makeLenses ''St -firstEditor :: T.Name -firstEditor = "edit1" - -secondEditor :: T.Name -secondEditor = "edit2" - -switchEditors :: St -> St -switchEditors st = - let next = if st^.currentEditor == firstEditor - then secondEditor else firstEditor - in st & currentEditor .~ next - -currentEditorL :: St -> Lens' St E.Editor -currentEditorL st = - if st^.currentEditor == firstEditor - then edit1 - else edit2 - -drawUI :: St -> [T.Widget] +drawUI :: St -> [T.Widget Name] drawUI st = [ui] where - ui = C.center $ (str "Input 1 (unlimited): " <+> (hLimit 30 $ vLimit 5 $ E.renderEditor $ st^.edit1)) <=> - str " " <=> - (str "Input 2 (limited to 2 lines): " <+> (hLimit 30 $ E.renderEditor $ st^.edit2)) <=> - str " " <=> - str "Press Tab to switch between editors, Esc to quit." + e1 = F.withFocusRing (st^.focusRing) (E.renderEditor (str . unlines)) (st^.edit1) + e2 = F.withFocusRing (st^.focusRing) (E.renderEditor (str . unlines)) (st^.edit2) -appEvent :: St -> V.Event -> T.EventM (T.Next St) -appEvent st ev = - case ev of - V.EvKey V.KEsc [] -> M.halt st - V.EvKey (V.KChar '\t') [] -> M.continue $ switchEditors st - _ -> M.continue =<< T.handleEventLensed st (currentEditorL st) ev + ui = C.center $ + (str "Input 1 (unlimited): " <+> (hLimit 30 $ vLimit 5 e1)) <=> + str " " <=> + (str "Input 2 (limited to 2 lines): " <+> (hLimit 30 e2)) <=> + str " " <=> + str "Press Tab to switch between editors, Esc to quit." +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = + M.halt +appEvent (T.VtyEvent (V.EvKey (V.KChar '\t') [])) = + focusRing %= F.focusNext +appEvent (T.VtyEvent (V.EvKey V.KBackTab [])) = + focusRing %= F.focusPrev +appEvent ev = do + r <- use focusRing + case F.focusGetCurrent r of + Just Edit1 -> zoom edit1 $ E.handleEditorEvent ev + Just Edit2 -> zoom edit2 $ E.handleEditorEvent ev + Nothing -> return () + initialState :: St initialState = - St firstEditor - (E.editor firstEditor (str . unlines) Nothing "") - (E.editor secondEditor (str . unlines) (Just 2) "") + St (F.focusRing [Edit1, Edit2]) + (E.editor Edit1 Nothing "") + (E.editor Edit2 (Just 2) "") theMap :: A.AttrMap theMap = A.attrMap V.defAttr - [ (E.editAttr, V.white `on` V.blue) + [ (E.editAttr, V.white `on` V.blue) + , (E.editFocusedAttr, V.black `on` V.yellow) ] -appCursor :: St -> [T.CursorLocation] -> Maybe T.CursorLocation -appCursor st = M.showCursorNamed (st^.currentEditor) +appCursor :: St -> [T.CursorLocation Name] -> Maybe (T.CursorLocation Name) +appCursor = F.focusRingCursor (^.focusRing) -theApp :: M.App St V.Event +theApp :: M.App St e Name theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = appCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap - , M.appLiftVtyEvent = id } main :: IO () diff --git a/programs/EditorLineNumbersDemo.hs b/programs/EditorLineNumbersDemo.hs new file mode 100644 --- /dev/null +++ b/programs/EditorLineNumbersDemo.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +module Main where + +import Control.Monad (void) +import Lens.Micro +import Lens.Micro.TH +import Lens.Micro.Mtl +import qualified Graphics.Vty as V +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif + +import qualified Brick.Main as M +import qualified Brick.Types as T +import Brick.Widgets.Core + ( (<+>) + , vBox + , hLimit + , vLimit + , str + , visible + , viewport + , withDefAttr + ) +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Edit as E +import qualified Brick.AttrMap as A +import Brick.Util (on, fg) + +data Name = Edit + | EditLines + deriving (Ord, Show, Eq) + +data St = + St { _edit :: E.Editor String Name + } + +makeLenses ''St + +drawUI :: St -> [T.Widget Name] +drawUI st = [ui] + where + e = renderWithLineNumbers (st^.edit) + ui = C.center $ hLimit 50 $ vLimit 10 e + +-- | Given an editor, render the editor with line numbers to the left of +-- the editor. +-- +-- This essentially exploits knowledge of how the editor is implemented: +-- we make a viewport containing line numbers that is just as high as +-- the editor, then request that the line number associated with the +-- editor's current line position be made visible, thus scrolling it +-- into view. This is slightly brittle, however, because it relies on +-- essentially keeping the line number viewport and the editor viewport +-- in the same vertical scrolling state; with direct scrolling requests +-- from EventM it is easily possible to put the two viewports into a +-- state where they do not have the same vertical scrolling offset. That +-- means that visibility requests made with 'visible' won't necessarily +-- have the same effect in each viewport in that case. So this is +-- only really usable in the case where you're sure that the editor's +-- viewport and the line number viewports will not be managed by direct +-- viewport operations in EventM. That's what I'd recommend anyway, but +-- still, this is an important caveat. +-- +-- There's another important caveat here: this particular implementation +-- has @O(n)@ performance for editor height @n@ because we generate +-- the entire list of line numbers on each rendering depending on the +-- height of the editor. That means that for sufficiently large files, +-- it will get more expensive to render the line numbers. There is a way +-- around this problem, which is to take the approach that the @List@ +-- implementation takes: only render a region of visible line numbers +-- around the currently-edited line that is just large enough to be +-- guaranteed to fill the viewport, then translate that so that it +-- appears at the right viewport offset, thus faking a viewport filled +-- with line numbers when in fact we'd only ever render at most @2 * K + +-- 1@ line numbers for a viewport height of @K@. That's more involved, +-- so I didn't do it here, but that would be the way to go for a Real +-- Application. +renderWithLineNumbers :: E.Editor String Name -> T.Widget Name +renderWithLineNumbers e = + lineNumbersVp <+> editorVp + where + lineNumbersVp = hLimit (maxNumWidth + 1) $ viewport EditLines T.Vertical body + editorVp = E.renderEditor (str . unlines) True e + body = withDefAttr lineNumberAttr $ vBox numWidgets + numWidgets = mkNumWidget <$> numbers + mkNumWidget i = maybeVisible i $ str $ show i + maybeVisible i + | i == curLine + 1 = + visible . withDefAttr currentLineNumberAttr + | otherwise = + id + numbers = [1..h] + contents = E.getEditContents e + h = length contents + curLine = fst $ E.getCursorPosition e + maxNumWidth = length $ show h + +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = + M.halt +appEvent ev = do + zoom edit $ E.handleEditorEvent ev + +initialState :: St +initialState = + St (E.editor Edit Nothing "") + +lineNumberAttr :: A.AttrName +lineNumberAttr = A.attrName "lineNumber" + +currentLineNumberAttr :: A.AttrName +currentLineNumberAttr = lineNumberAttr <> A.attrName "current" + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (E.editAttr, V.white `on` V.blue) + , (E.editFocusedAttr, V.black `on` V.yellow) + , (lineNumberAttr, fg V.cyan) + , (currentLineNumberAttr, V.defAttr `V.withStyle` V.bold) + ] + +theApp :: M.App St e Name +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = const $ M.showCursorNamed Edit + , M.appHandleEvent = appEvent + , M.appStartEvent = return () + , M.appAttrMap = const theMap + } + +main :: IO () +main = do + void $ M.defaultMain theApp initialState diff --git a/programs/FileBrowserDemo.hs b/programs/FileBrowserDemo.hs new file mode 100644 --- /dev/null +++ b/programs/FileBrowserDemo.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Main where + +import qualified Control.Exception as E +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import qualified Graphics.Vty as V + +import Control.Monad.State (get) +import qualified Data.Text as Text +import qualified Brick.Main as M +import qualified Brick.Widgets.List as L +import Brick.AttrMap (AttrName, attrName) +import Brick.Types + ( Widget + , BrickEvent(..) + ) +import Brick.Widgets.Center + ( center + , hCenter + ) +import Brick.Widgets.Border + ( borderWithLabel + ) +import Brick.Widgets.Core + ( vBox, (<=>), padTop + , hLimit, vLimit, txt + , withDefAttr, emptyWidget + , Padding(..) + ) +import qualified Brick.Widgets.FileBrowser as FB +import qualified Brick.AttrMap as A +import Brick.Util (on, fg) +import qualified Brick.Types as T + +data Name = FileBrowser1 + deriving (Eq, Show, Ord) + +drawUI :: FB.FileBrowser Name -> [Widget Name] +drawUI b = [center $ ui <=> help] + where + ui = hCenter $ + vLimit 15 $ + hLimit 50 $ + borderWithLabel (txt "Choose a file") $ + FB.renderFileBrowser True b + help = padTop (Pad 1) $ + vBox [ case FB.fileBrowserException b of + Nothing -> emptyWidget + Just e -> hCenter $ withDefAttr errorAttr $ + txt $ Text.pack $ E.displayException e + , hCenter $ txt "Up/Down: select" + , hCenter $ txt "/: search, Ctrl-C or Esc: cancel search" + , hCenter $ txt "Enter: change directory or select file" + , hCenter $ txt "Esc: quit" + ] + +appEvent :: BrickEvent Name e -> T.EventM Name (FB.FileBrowser Name) () +appEvent (VtyEvent ev) = do + b <- get + case ev of + V.EvKey V.KEsc [] | not (FB.fileBrowserIsSearching b) -> + M.halt + _ -> do + FB.handleFileBrowserEvent ev + -- If the browser has a selected file after handling the + -- event (because the user pressed Enter), shut down. + case ev of + V.EvKey V.KEnter [] -> do + b' <- get + case FB.fileBrowserSelection b' of + [] -> return () + _ -> M.halt + _ -> return () +appEvent _ = return () + +errorAttr :: AttrName +errorAttr = attrName "error" + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (L.listSelectedFocusedAttr, V.black `on` V.yellow) + , (FB.fileBrowserCurrentDirectoryAttr, V.white `on` V.blue) + , (FB.fileBrowserSelectionInfoAttr, V.white `on` V.blue) + , (FB.fileBrowserDirectoryAttr, fg V.blue) + , (FB.fileBrowserBlockDeviceAttr, fg V.magenta) + , (FB.fileBrowserCharacterDeviceAttr, fg V.green) + , (FB.fileBrowserNamedPipeAttr, fg V.yellow) + , (FB.fileBrowserSymbolicLinkAttr, fg V.cyan) + , (FB.fileBrowserUnixSocketAttr, fg V.red) + , (FB.fileBrowserSelectedAttr, V.white `on` V.magenta) + , (errorAttr, fg V.red) + ] + +theApp :: M.App (FB.FileBrowser Name) e Name +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return () + , M.appAttrMap = const theMap + } + +main :: IO () +main = do + b <- M.defaultMain theApp =<< FB.newFileBrowser FB.selectNonDirectories FileBrowser1 Nothing + putStrLn $ "Selected entry: " <> show (FB.fileBrowserSelection b) diff --git a/programs/FillDemo.hs b/programs/FillDemo.hs new file mode 100644 --- /dev/null +++ b/programs/FillDemo.hs @@ -0,0 +1,16 @@ +module Main where + +import Brick +import Brick.Widgets.Border + +ui :: Widget () +ui = vBox [ vLimitPercent 20 $ vBox [ str "This text is in the top 20% of the window due to a fill and vLimitPercent." + , fill ' ' + , hBorder + ] + , str "This text is at the bottom with another fill beneath it." + , fill 'x' + ] + +main :: IO () +main = simpleMain ui diff --git a/programs/FormDemo.hs b/programs/FormDemo.hs new file mode 100644 --- /dev/null +++ b/programs/FormDemo.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Data.Text as T +import Lens.Micro ((^.)) +import Lens.Micro.TH +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif + +import qualified Graphics.Vty as V +import Graphics.Vty.CrossPlatform (mkVty) + +import Brick +import Brick.Forms + ( Form + , newForm + , formState + , formFocus + , setFieldValid + , renderForm + , handleFormEvent + , invalidFields + , allFieldsValid + , focusedFormInputAttr + , invalidFormInputAttr + , checkboxField + , radioField + , editShowableField + , editTextField + , editPasswordField + , (@@=) + ) +import Brick.Focus + ( focusGetCurrent + , focusRingCursor + ) +import qualified Brick.Widgets.Edit as E +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Center as C + +data Name = NameField + | AgeField + | BikeField + | HandedField + | PasswordField + | LeftHandField + | RightHandField + | AmbiField + | AddressField + deriving (Eq, Ord, Show) + +data Handedness = LeftHanded | RightHanded | Ambidextrous + deriving (Show, Eq) + +data UserInfo = + UserInfo { _name :: T.Text + , _age :: Int + , _address :: T.Text + , _ridesBike :: Bool + , _handed :: Handedness + , _password :: T.Text + } + deriving (Show) + +makeLenses ''UserInfo + +-- This form is covered in the Brick User Guide; see the "Input Forms" +-- section. +mkForm :: UserInfo -> Form UserInfo e Name +mkForm = + let label s w = padBottom (Pad 1) $ + (vLimit 1 $ hLimit 15 $ str s <+> fill ' ') <+> w + in newForm [ label "Name" @@= + editTextField name NameField (Just 1) + , label "Address" @@= + B.borderWithLabel (str "Mailing") @@= + editTextField address AddressField (Just 3) + , label "Age" @@= + editShowableField age AgeField + , label "Password" @@= + editPasswordField password PasswordField + , label "Dominant hand" @@= + radioField handed [ (LeftHanded, LeftHandField, "Left") + , (RightHanded, RightHandField, "Right") + , (Ambidextrous, AmbiField, "Both") + ] + , label "" @@= + checkboxField ridesBike BikeField "Do you ride a bicycle?" + ] + +theMap :: AttrMap +theMap = attrMap V.defAttr + [ (E.editAttr, V.white `on` V.black) + , (E.editFocusedAttr, V.black `on` V.yellow) + , (invalidFormInputAttr, V.white `on` V.red) + , (focusedFormInputAttr, V.black `on` V.yellow) + ] + +draw :: Form UserInfo e Name -> [Widget Name] +draw f = [C.vCenter $ C.hCenter form <=> C.hCenter help] + where + form = B.border $ padTop (Pad 1) $ hLimit 50 $ renderForm f + 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" <> + "- Handedness selects from a list of options\n" <> + "- The last option is a checkbox\n" <> + "- Enter/Esc quit, mouse interacts with fields" + +app :: App (Form UserInfo e Name) e Name +app = + App { appDraw = draw + , appHandleEvent = \ev -> do + f <- gets formFocus + case ev of + VtyEvent (V.EvResize {}) -> return () + VtyEvent (V.EvKey V.KEsc []) -> halt + -- Enter quits only when we aren't in the multi-line editor. + VtyEvent (V.EvKey V.KEnter []) + | focusGetCurrent f /= Just AddressField -> halt + _ -> do + handleFormEvent ev + + -- Example of external validation: + -- Require age field to contain a value that is at least 18. + st <- gets formState + modify $ setFieldValid (st^.age >= 18) AgeField + + , appChooseCursor = focusRingCursor formFocus + , appStartEvent = return () + , appAttrMap = const theMap + } + +main :: IO () +main = do + let buildVty = do + v <- mkVty V.defaultConfig + V.setMode (V.outputIface v) V.Mouse True + return v + + initialUserInfo = UserInfo { _name = "" + , _address = "" + , _age = 0 + , _handed = RightHanded + , _ridesBike = False + , _password = "" + } + f = setFieldValid False AgeField $ + mkForm initialUserInfo + + initialVty <- buildVty + f' <- customMain initialVty buildVty Nothing app f + + putStrLn "The starting form state was:" + print initialUserInfo + + putStrLn "The final form state was:" + print $ formState f' + + if allFieldsValid f' + then putStrLn "The final form inputs were valid." + else putStrLn $ "The final form had invalid inputs: " <> show (invalidFields f') diff --git a/programs/HelloWorldDemo.hs b/programs/HelloWorldDemo.hs --- a/programs/HelloWorldDemo.hs +++ b/programs/HelloWorldDemo.hs @@ -2,7 +2,7 @@ import Brick -ui :: Widget +ui :: Widget () ui = str "Hello, world!" main :: IO () diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs --- a/programs/LayerDemo.hs +++ b/programs/LayerDemo.hs @@ -1,70 +1,108 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Lens (makeLenses, (^.), (&), (%~)) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import Lens.Micro ((^.)) +import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void) -import Data.Default import qualified Graphics.Vty as V import qualified Brick.Types as T -import Brick.Types (rowL, columnL) +import Brick.Types (locationRowL, locationColumnL, Location(..), Widget) import qualified Brick.Main as M import qualified Brick.Widgets.Border as B -import Brick.Types - ( Widget - ) +import qualified Brick.Widgets.Center as C import Brick.Widgets.Core ( translateBy , str + , relativeTo + , reportExtent + , withDefAttr ) +import Brick.Util (fg) +import Brick.AttrMap + ( attrMap + , AttrName + , attrName + ) data St = - St { _topLayerLocation :: T.Location + St { _middleLayerLocation :: T.Location , _bottomLayerLocation :: T.Location } makeLenses ''St -drawUi :: St -> [Widget] +data Name = + MiddleLayerElement + deriving (Ord, Eq, Show) + +drawUi :: St -> [Widget Name] drawUi st = - [ topLayer st - , bottomLayer st + [ C.centerLayer $ + B.border $ str "This layer is centered but other\nlayers are placed underneath it." + , arrowLayer + , middleLayer (st^.middleLayerLocation) + , bottomLayer (st^.bottomLayerLocation) ] -topLayer :: St -> Widget -topLayer st = - translateBy (st^.topLayerLocation) $ - B.border $ str "Top layer\n(Arrow keys move)" +arrowLayer :: Widget Name +arrowLayer = + let msg = "Relatively\n" <> + "positioned\n" <> + "arrow---->" + in relativeTo MiddleLayerElement (Location (-10, -2)) $ + withDefAttr arrowAttr $ + str msg -bottomLayer :: St -> Widget -bottomLayer st = - translateBy (st^.bottomLayerLocation) $ +middleLayer :: Location -> Widget Name +middleLayer l = + translateBy l $ + reportExtent MiddleLayerElement $ + B.border $ str "Middle layer\n(Arrow keys move)" + +bottomLayer :: Location -> Widget Name +bottomLayer l = + translateBy l $ B.border $ str "Bottom layer\n(Ctrl-arrow keys move)" -appEvent :: St -> V.Event -> T.EventM (T.Next St) -appEvent st (V.EvKey V.KDown []) = M.continue $ st & topLayerLocation.rowL %~ (+ 1) -appEvent st (V.EvKey V.KUp []) = M.continue $ st & topLayerLocation.rowL %~ (subtract 1) -appEvent st (V.EvKey V.KRight []) = M.continue $ st & topLayerLocation.columnL %~ (+ 1) -appEvent st (V.EvKey V.KLeft []) = M.continue $ st & topLayerLocation.columnL %~ (subtract 1) +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = + middleLayerLocation.locationRowL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = + middleLayerLocation.locationRowL %= (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = + middleLayerLocation.locationColumnL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = + middleLayerLocation.locationColumnL %= (subtract 1) -appEvent st (V.EvKey V.KDown [V.MCtrl]) = M.continue $ st & bottomLayerLocation.rowL %~ (+ 1) -appEvent st (V.EvKey V.KUp [V.MCtrl]) = M.continue $ st & bottomLayerLocation.rowL %~ (subtract 1) -appEvent st (V.EvKey V.KRight [V.MCtrl]) = M.continue $ st & bottomLayerLocation.columnL %~ (+ 1) -appEvent st (V.EvKey V.KLeft [V.MCtrl]) = M.continue $ st & bottomLayerLocation.columnL %~ (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = + bottomLayerLocation.locationRowL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = + bottomLayerLocation.locationRowL %= (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = + bottomLayerLocation.locationColumnL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = + bottomLayerLocation.locationColumnL %= (subtract 1) -appEvent st (V.EvKey V.KEsc []) = M.halt st -appEvent st _ = M.continue st +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () -app :: M.App St V.Event +arrowAttr :: AttrName +arrowAttr = attrName "attr" + +app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent - , M.appAttrMap = const def - , M.appLiftVtyEvent = id + , M.appAttrMap = const $ attrMap V.defAttr [(arrowAttr, fg V.cyan)] , M.appChooseCursor = M.neverShowCursor } main :: IO () -main = void $ M.defaultMain app $ St (T.Location (0, 0)) (T.Location (0, 0)) +main = void $ M.defaultMain app $ St (T.Location (20, 5)) (T.Location (0, 0)) diff --git a/programs/ListDemo.hs b/programs/ListDemo.hs --- a/programs/ListDemo.hs +++ b/programs/ListDemo.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Main where -import Control.Lens ((^.)) +import Lens.Micro ((^.)) +import Lens.Micro.Mtl import Control.Monad (void) +import Control.Monad.State (modify) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid +#endif import Data.Maybe (fromMaybe) import qualified Graphics.Vty as V @@ -13,7 +17,7 @@ import qualified Brick.Widgets.List as L import qualified Brick.Widgets.Center as C import qualified Brick.AttrMap as A -import qualified Data.Vector as V +import qualified Data.Vector as Vec import Brick.Types ( Widget ) @@ -27,56 +31,59 @@ ) import Brick.Util (fg, on) -drawUI :: (Show a) => L.List a -> [Widget] +drawUI :: (Show a) => L.List () a -> [Widget ()] drawUI l = [ui] where label = str "Item " <+> cur <+> str " of " <+> total cur = case l^.(L.listSelectedL) of Nothing -> str "-" Just i -> str (show (i + 1)) - total = str $ show $ V.length $ l^.(L.listElementsL) + total = str $ show $ Vec.length $ l^.(L.listElementsL) box = B.borderWithLabel label $ hLimit 25 $ vLimit 15 $ - L.renderList l listDrawElement + L.renderList listDrawElement True l ui = C.vCenter $ vBox [ C.hCenter box , str " " , C.hCenter $ str "Press +/- to add/remove list elements." , C.hCenter $ str "Press Esc to exit." ] -appEvent :: L.List Char -> V.Event -> T.EventM (T.Next (L.List Char)) -appEvent l e = +appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Char) () +appEvent (T.VtyEvent e) = case e of - V.EvKey (V.KChar '+') [] -> - let el = nextElement (L.listElements l) - pos = V.length $ l^.(L.listElementsL) - in M.continue $ L.listInsert pos el l + V.EvKey (V.KChar '+') [] -> do + els <- use L.listElementsL + let el = nextElement els + pos = Vec.length els + modify $ L.listInsert pos el - V.EvKey (V.KChar '-') [] -> - case l^.(L.listSelectedL) of - Nothing -> M.continue l - Just i -> M.continue $ L.listRemove i l + V.EvKey (V.KChar '-') [] -> do + sel <- use L.listSelectedL + case sel of + Nothing -> return () + Just i -> modify $ L.listRemove i - V.EvKey V.KEsc [] -> M.halt l + V.EvKey V.KEsc [] -> M.halt - ev -> M.continue =<< T.handleEvent ev l + ev -> L.handleListEvent ev where - nextElement :: V.Vector Char -> Char - nextElement v = fromMaybe '?' $ V.find (flip V.notElem v) (V.fromList ['a' .. 'z']) + nextElement :: Vec.Vector Char -> Char + nextElement v = fromMaybe '?' $ Vec.find (flip Vec.notElem v) (Vec.fromList ['a' .. 'z']) +appEvent _ = return () -listDrawElement :: (Show a) => Bool -> a -> Widget +listDrawElement :: (Show a) => Bool -> a -> Widget () listDrawElement sel a = let selStr s = if sel then withAttr customAttr (str $ "<" <> s <> ">") else str s in C.hCenter $ str "Item " <+> (selStr $ show a) -initialState :: L.List Char -initialState = L.list (T.Name "list") (V.fromList ['a','b','c']) 1 +initialState :: L.List () Char +initialState = L.list () (Vec.fromList ['a','b','c']) 1 customAttr :: A.AttrName -customAttr = L.listSelectedAttr <> "custom" +customAttr = L.listSelectedAttr <> A.attrName "custom" theMap :: A.AttrMap theMap = A.attrMap V.defAttr @@ -85,14 +92,13 @@ , (customAttr, fg V.cyan) ] -theApp :: M.App (L.List Char) V.Event +theApp :: M.App (L.List () Char) e () theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap - , M.appLiftVtyEvent = id } main :: IO () diff --git a/programs/ListViDemo.hs b/programs/ListViDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ListViDemo.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Control.Monad (void) +import Control.Monad.State (modify) +import Data.Maybe (fromMaybe) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import qualified Graphics.Vty as V +import Lens.Micro ((^.)) +import Lens.Micro.Mtl + +import qualified Brick.AttrMap as A +import qualified Brick.Main as M +import Brick.Types (Widget) +import qualified Brick.Types as T +import Brick.Util (fg, on) +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Center as C +import Brick.Widgets.Core (hLimit, str, vBox, vLimit, withAttr, (<+>)) +import qualified Brick.Widgets.List as L +import qualified Data.Vector as Vec + +drawUI :: (Show a) => L.List () a -> [Widget ()] +drawUI l = [ui] + where + label = str "Item " <+> cur <+> str " of " <+> total + cur = case l^.(L.listSelectedL) of + Nothing -> str "-" + Just i -> str (show (i + 1)) + total = str $ show $ Vec.length $ l^.(L.listElementsL) + box = B.borderWithLabel label $ + hLimit 25 $ + vLimit 15 $ + L.renderList listDrawElement True l + ui = C.vCenter $ vBox [ C.hCenter box + , str " " + , C.hCenter $ str "Press +/- to add/remove list elements." + , C.hCenter $ str "Press Esc to exit." + ] + +appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Char) () +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 + + V.EvKey (V.KChar '-') [] -> do + sel <- use L.listSelectedL + case sel of + Nothing -> return () + Just i -> modify $ L.listRemove i + + V.EvKey V.KEsc [] -> M.halt + + ev -> L.handleListEventVi L.handleListEvent ev + where + nextElement :: Vec.Vector Char -> Char + nextElement v = fromMaybe '?' $ Vec.find (flip Vec.notElem v) (Vec.fromList ['a' .. 'z']) +appEvent _ = return () + +listDrawElement :: (Show a) => Bool -> a -> Widget () +listDrawElement sel a = + let selStr s = if sel + then withAttr customAttr (str $ "<" <> s <> ">") + else str s + in C.hCenter $ str "Item " <+> (selStr $ show a) + +initialState :: L.List () Char +initialState = L.list () (Vec.fromList ['a','b','c']) 1 + +customAttr :: A.AttrName +customAttr = L.listSelectedAttr <> A.attrName "custom" + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (L.listAttr, V.white `on` V.blue) + , (L.listSelectedAttr, V.blue `on` V.white) + , (customAttr, fg V.cyan) + ] + +theApp :: M.App (L.List () Char) e () +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return () + , M.appAttrMap = const theMap + } + +main :: IO () +main = void $ M.defaultMain theApp initialState diff --git a/programs/MarkupDemo.hs b/programs/MarkupDemo.hs deleted file mode 100644 --- a/programs/MarkupDemo.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Data.Monoid ((<>)) -import qualified Graphics.Vty as V - -import Brick.Main (App(..), defaultMain, resizeOrQuit, neverShowCursor) -import Brick.Types - ( Widget - ) -import Brick.Widgets.Core - ( (<=>) - ) -import Brick.Util (on, fg) -import Brick.Markup (markup, (@?)) -import Brick.AttrMap (attrMap, AttrMap) -import Data.Text.Markup ((@@)) - -ui :: Widget -ui = m1 <=> m2 - where - m1 = markup $ ("Hello" @@ fg V.blue) <> ", " <> ("world!" @@ fg V.red) - m2 = markup $ ("Hello" @? "keyword1") <> ", " <> ("world!" @? "keyword2") - -theMap :: AttrMap -theMap = attrMap V.defAttr - [ ("keyword1", fg V.magenta) - , ("keyword2", V.white `on` V.blue) - ] - -app :: App () V.Event -app = - App { appDraw = const [ui] - , appHandleEvent = resizeOrQuit - , appAttrMap = const theMap - , appStartEvent = return - , appChooseCursor = neverShowCursor - , appLiftVtyEvent = id - } - -main :: IO () -main = defaultMain app () diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs new file mode 100644 --- /dev/null +++ b/programs/MouseDemo.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Lens.Micro ((^.)) +import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl +import Control.Monad (void) +import Control.Monad.Trans (liftIO) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Graphics.Vty as V + +import qualified Brick.Types as T +import Brick.AttrMap +import Brick.Util +import Brick.Types (Widget, ViewportType(Vertical)) +import qualified Brick.Main as M +import qualified Brick.Widgets.Edit as E +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Border as B +import Brick.Widgets.Core + +data Name = Info | Button1 | Button2 | Button3 | Prose | TextBox + deriving (Show, Ord, Eq) + +data St = + St { _clicked :: [T.Extent Name] + , _lastReportedClick :: Maybe (Name, T.Location) + , _prose :: String + , _edit :: E.Editor String Name + } + +makeLenses ''St + +drawUi :: St -> [Widget Name] +drawUi st = + [ buttonLayer st + , proseLayer st + , infoLayer st + ] + +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)) + where + buttons = mkButton <$> buttonData + buttonData = [ (Button1, "Button 1", attrName "button1") + , (Button2, "Button 2", attrName "button2") + , (Button3, "Button 3", attrName "button3") + ] + mkButton (name, label, attr) = + let wasClicked = (fst <$> st^.lastReportedClick) == Just name + in clickable name $ + withDefAttr attr $ + B.border $ + padTopBottom 1 $ + padLeftRight (if wasClicked then 2 else 3) $ + str (if wasClicked then "<" <> label <> ">" else label) + +proseLayer :: St -> Widget Name +proseLayer st = + B.border $ + C.hCenterLayer $ + vLimit 8 $ + viewport Prose Vertical $ + vBox $ map str $ lines (st^.prose) + +infoLayer :: St -> Widget Name +infoLayer st = T.Widget T.Fixed T.Fixed $ do + c <- T.getContext + let h = c^.T.availHeightL + msg = case st^.lastReportedClick of + Nothing -> + "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 $ + withDefAttr (attrName "info") $ + C.hCenter $ str msg + +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent ev@(T.MouseDown n _ _ loc) = do + lastReportedClick .= Just (n, loc) + zoom edit $ E.handleEditorEvent ev +appEvent (T.MouseUp {}) = + lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvMouseUp {})) = + lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = + M.vScrollBy (M.viewportScroll Prose) (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = + M.vScrollBy (M.viewportScroll Prose) 1 +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = + M.halt +appEvent ev = + zoom edit $ E.handleEditorEvent ev + +aMap :: AttrMap +aMap = attrMap V.defAttr + [ (attrName "info", V.white `on` V.magenta) + , (attrName "button1", V.white `on` V.cyan) + , (attrName "button2", V.white `on` V.green) + , (attrName "button3", V.white `on` V.blue) + , (E.editFocusedAttr, V.black `on` V.yellow) + ] + +app :: M.App St e Name +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = do + vty <- M.getVtyHandle + liftIO $ V.setMode (V.outputIface vty) V.Mouse True + , M.appHandleEvent = appEvent + , M.appAttrMap = const aMap + , M.appChooseCursor = M.showFirstCursor + } + +main :: IO () +main = do + void $ M.defaultMain app $ St [] Nothing + (unlines [ "Try clicking on various UI elements." + , "Observe that the click coordinates identify the" + , "underlying widget coordinates." + , "" + , "Lorem ipsum dolor sit amet," + , "consectetur adipiscing elit," + , "sed do eiusmod tempor incididunt ut labore" + , "et dolore magna aliqua." + , "" + , "Ut enim ad minim veniam" + , "quis nostrud exercitation ullamco laboris" + , "isi ut aliquip ex ea commodo consequat." + , "" + , "Duis aute irure dolor in reprehenderit" + , "in voluptate velit esse cillum dolore eu fugiat nulla pariatur." + , "" + , "Excepteur sint occaecat cupidatat not proident," + , "sunt in culpa qui officia deserunt mollit" + , "anim id est laborum." + ]) + (E.editor TextBox Nothing "") diff --git a/programs/PaddingDemo.hs b/programs/PaddingDemo.hs --- a/programs/PaddingDemo.hs +++ b/programs/PaddingDemo.hs @@ -1,13 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Data.Default -import qualified Graphics.Vty as V - import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) import Brick.Types ( Widget - , Padding(..) ) import Brick.Widgets.Core ( vBox @@ -20,20 +16,23 @@ , padBottom , padTopBottom , padLeftRight + , Padding(..) ) -import Brick.Widgets.Border as B -import Brick.Widgets.Center as C +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Center as C +import Brick.AttrMap (attrMap) +import qualified Graphics.Vty as V -ui :: Widget +ui :: Widget () ui = - vBox [ hBox [ padLeft Max $ vCenter $ str "Left-padded" + vBox [ hBox [ padLeft Max $ C.vCenter $ str "Left-padded" , B.vBorder - , padRight Max $ vCenter $ str "Right-padded" + , padRight Max $ C.vCenter $ str "Right-padded" ] , B.hBorder - , hBox [ padTop Max $ hCenter $ str "Top-padded" + , hBox [ padTop Max $ C.hCenter $ str "Top-padded" , B.vBorder - , padBottom Max $ hCenter $ str "Bottom-padded" + , padBottom Max $ C.hCenter $ str "Bottom-padded" ] , B.hBorder , hBox [ padLeftRight 2 $ str "Padded by 2 on left/right" @@ -46,14 +45,13 @@ , padAll 2 $ str "Padded by 2 on all sides" ] -app :: App () V.Event +app :: App () e () app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return - , appAttrMap = const def + , appStartEvent = return () + , appAttrMap = const $ attrMap V.defAttr [] , appChooseCursor = neverShowCursor - , appLiftVtyEvent = id } main :: IO () diff --git a/programs/ProgressBarDemo.hs b/programs/ProgressBarDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ProgressBarDemo.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Monad (void) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import qualified Graphics.Vty as V +import Lens.Micro.Mtl +import Lens.Micro.TH + +import qualified Brick.AttrMap as A +import qualified Brick.Main as M +import qualified Brick.Types as T +import qualified Brick.Widgets.ProgressBar as P +import Brick.Types + ( Widget + ) +import Brick.Widgets.Core + ( (<+>), (<=>) + , str + , strWrap + , updateAttrMap + , overrideAttr + ) +import Brick.Util (fg, bg, on, clamp) + +data MyAppState n = MyAppState { _x, _y, _z :: Float, _showLabel :: Bool } + +makeLenses ''MyAppState + +drawUI :: MyAppState () -> [Widget ()] +drawUI p = [ui] + where + -- use mapAttrNames + xBar = updateAttrMap + (A.mapAttrNames [ (xDoneAttr, P.progressCompleteAttr) + , (xToDoAttr, P.progressIncompleteAttr) + ] + ) $ bar $ _x p + -- or use individual mapAttrName calls + yBar = updateAttrMap + (A.mapAttrName yDoneAttr P.progressCompleteAttr . + A.mapAttrName yToDoAttr P.progressIncompleteAttr) $ + bar $ _y p + -- or use overrideAttr calls + zBar = overrideAttr P.progressCompleteAttr zDoneAttr $ + overrideAttr P.progressIncompleteAttr zToDoAttr $ + bar $ _z p + -- 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 "" <=> + (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) = + let valid = clamp (0.0 :: Float) 1.0 + in case e of + 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 True + +theBaseAttr :: A.AttrName +theBaseAttr = A.attrName "theBase" + +xDoneAttr, xToDoAttr :: A.AttrName +xDoneAttr = theBaseAttr <> A.attrName "X:done" +xToDoAttr = theBaseAttr <> A.attrName "X:remaining" + +yDoneAttr, yToDoAttr :: A.AttrName +yDoneAttr = theBaseAttr <> A.attrName "Y:done" +yToDoAttr = theBaseAttr <> A.attrName "Y:remaining" + +zDoneAttr, zToDoAttr :: A.AttrName +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) + , (xDoneAttr, V.black `on` V.white) + , (xToDoAttr, V.white `on` V.black) + , (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) + ] + +theApp :: M.App (MyAppState ()) e () +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return () + , M.appAttrMap = const theMap + } + +main :: IO () +main = void $ M.defaultMain theApp initialState diff --git a/programs/ReadmeDemo.hs b/programs/ReadmeDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ReadmeDemo.hs @@ -0,0 +1,16 @@ +module Main where + +import Brick (Widget, simpleMain, (<+>), str, withBorderStyle, joinBorders) +import Brick.Widgets.Center (center) +import Brick.Widgets.Border (borderWithLabel, vBorder) +import Brick.Widgets.Border.Style (unicode) + +ui :: Widget () +ui = + joinBorders $ + withBorderStyle unicode $ + borderWithLabel (str "Hello!") $ + (center (str "Left") <+> vBorder <+> center (str "Right")) + +main :: IO () +main = simpleMain ui diff --git a/programs/SuspendAndResumeDemo.hs b/programs/SuspendAndResumeDemo.hs --- a/programs/SuspendAndResumeDemo.hs +++ b/programs/SuspendAndResumeDemo.hs @@ -1,21 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module Main where -import Control.Lens (makeLenses, (.~), (^.), (&)) +import Lens.Micro ((^.)) +import Lens.Micro.TH (makeLenses) import Control.Monad (void) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid -import Data.Default +#endif import qualified Graphics.Vty as V import Brick.Main ( App(..), neverShowCursor, defaultMain - , suspendAndResume, halt, continue + , suspendAndResume, halt ) +import Brick.AttrMap + ( attrMap + ) import Brick.Types ( Widget , EventM - , Next + , BrickEvent(..) ) import Brick.Widgets.Core ( vBox @@ -28,38 +34,38 @@ makeLenses ''St -drawUI :: St -> [Widget] +drawUI :: St -> [Widget ()] drawUI st = [ui] where ui = vBox [ str $ "External input: \"" <> st^.stExternalInput <> "\"" , str "(Press Esc to quit or Space to ask for input)" ] -appEvent :: St -> V.Event -> EventM (Next St) -appEvent st e = +appEvent :: BrickEvent () e -> EventM () St () +appEvent (VtyEvent e) = case e of - V.EvKey V.KEsc [] -> halt st + V.EvKey V.KEsc [] -> halt V.EvKey (V.KChar ' ') [] -> suspendAndResume $ do putStrLn "Suspended. Please enter something and press enter to resume:" s <- getLine - return $ st & stExternalInput .~ s - _ -> continue st + return $ St { _stExternalInput = s } + _ -> return () +appEvent _ = return () initialState :: St initialState = St { _stExternalInput = "" } -theApp :: App St V.Event +theApp :: App St e () theApp = App { appDraw = drawUI , appChooseCursor = neverShowCursor , appHandleEvent = appEvent - , appStartEvent = return - , appAttrMap = const def - , appLiftVtyEvent = id + , appStartEvent = return () + , appAttrMap = const $ attrMap V.defAttr [] } main :: IO () -main = do +main = void $ defaultMain theApp initialState diff --git a/programs/TableDemo.hs b/programs/TableDemo.hs new file mode 100644 --- /dev/null +++ b/programs/TableDemo.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Main where + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import Brick +import Brick.Widgets.Table +import Brick.Widgets.Center (center) + +ui :: Widget () +ui = center $ renderTable leftTable <+> + padLeft (Pad 5) (renderTable rightTableA <=> + renderTable rightTableB <=> + renderTable rightTableC) + +innerTable :: Table () +innerTable = + surroundingBorder False $ + table [ [txt "inner", txt "table"] + , [txt "is", txt "here"] + ] + +leftTable :: Table () +leftTable = + alignCenter 1 $ + alignRight 2 $ + alignMiddle 2 $ + table [ [txt "Left", txt "Center", txt "Right"] + , [txt "X", txt "Some things", txt "A"] + , [renderTable innerTable, txt "are", txt "B"] + , [txt "Z", txt "centered", txt "C"] + ] + +rightTableA :: Table () +rightTableA = + rowBorders False $ + setDefaultColAlignment AlignCenter $ + table [ [txt "A", txt "without"] + , [txt "table", txt "row borders"] + ] + +rightTableB :: Table () +rightTableB = + columnBorders False $ + setDefaultColAlignment AlignCenter $ + table [ [txt "A", txt "table"] + , [txt "without", txt "column borders"] + ] + +rightTableC :: Table () +rightTableC = + surroundingBorder False $ + rowBorders False $ + columnBorders False $ + setDefaultColAlignment AlignCenter $ + table [ [txt "A", txt "table"] + , [txt "without", txt "any borders"] + ] + +main :: IO () +main = simpleMain ui diff --git a/programs/TabularListDemo.hs b/programs/TabularListDemo.hs new file mode 100644 --- /dev/null +++ b/programs/TabularListDemo.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +module Main where + +import Lens.Micro ((^.)) +import Lens.Micro.Mtl +import Lens.Micro.TH +import Control.Monad (void) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import qualified Graphics.Vty as V + +import qualified Brick.Main as M +import qualified Brick.Types as T +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.List as L +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Table as Table +import qualified Brick.AttrMap as A +import qualified Data.Vector as Vec +import Brick.Types + ( Widget + ) +import Brick.Widgets.Core + ( (<=>) + , str + , vLimit + , hLimit + , vBox + , hBox + , withDefAttr + ) +import Brick.Util (on) + +data Row = Row String String String + +data AppState = + AppState { _tabularList :: L.List () Row + , _colIndex :: Int + } + +makeLenses ''AppState + +drawUI :: AppState -> [Widget ()] +drawUI s = [ui] + where + l = s^.tabularList + label = str $ "Row " <> cur <> " / col " <> show (s^.colIndex + 1) + cur = case l^.(L.listSelectedL) of + Nothing -> "-" + Just i -> show (i + 1) + box = B.borderWithLabel label $ + hLimit totalWidth $ + vLimit 15 $ + listDrawElement 0 False headerRow <=> + L.renderList (listDrawElement (s^.colIndex)) True l + ui = C.vCenter $ vBox [ C.hCenter box + , str " " + , C.hCenter $ str "Press +/- to add/remove list elements." + , C.hCenter $ str "Use arrow keys to change selection." + , C.hCenter $ str "Press Esc to exit." + ] + +appEvent :: T.BrickEvent () e -> T.EventM () AppState () +appEvent (T.VtyEvent e) = + case e of + V.EvKey (V.KChar '+') [] -> do + els <- use (tabularList.L.listElementsL) + let el = Row (show pos) (show $ pos * 3) (show $ pos * 9) + pos = Vec.length els + tabularList %= L.listInsert pos el + + V.EvKey (V.KChar '-') [] -> do + sel <- use (tabularList.L.listSelectedL) + case sel of + Nothing -> return () + Just i -> tabularList %= L.listRemove i + + V.EvKey V.KLeft [] -> + colIndex %= (\i -> max 0 (i - 1)) + V.EvKey V.KRight [] -> + colIndex %= (\i -> min (length columnAlignments - 1) (i + 1)) + + V.EvKey V.KEsc [] -> M.halt + + ev -> T.zoom tabularList $ L.handleListEvent ev +appEvent _ = return () + +listDrawElement :: Int -> Bool -> Row -> Widget () +listDrawElement colIdx sel (Row a b c) = + let ws = [str a, str b, str c] + maybeSelect es = selectCell <$> zip [0..] es + selectCell (i, w) = if sel && i == colIdx + then withDefAttr selectedCellAttr w + else w + in hLimit totalWidth $ + hBox $ + maybeSelect $ + Table.alignColumns columnAlignments columnWidths ws + +initialState :: AppState +initialState = + AppState { _tabularList = L.list () (Vec.fromList initialRows) 1 + , _colIndex = 0 + } + +selectedCellAttr :: A.AttrName +selectedCellAttr = A.attrName "selectedCell" + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (L.listAttr, V.white `on` V.blue) + , (selectedCellAttr, V.blue `on` V.white) + ] + +columnWidths :: [Int] +columnWidths = [10, 15, 20] + +totalWidth :: Int +totalWidth = sum columnWidths + +headerRow :: Row +headerRow = Row "Col 1" "Col 2" "Col 3" + +columnAlignments :: [Table.ColumnAlignment] +columnAlignments = [Table.AlignLeft, Table.AlignCenter, Table.AlignRight] + +initialRows :: [Row] +initialRows = + [ Row "one" "two" "three" + , Row "foo" "bar" "baz" + , Row "stuff" "things" "blah" + ] + +theApp :: M.App AppState e () +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return () + , M.appAttrMap = const theMap + } + +main :: IO () +main = void $ M.defaultMain theApp initialState diff --git a/programs/TailDemo.hs b/programs/TailDemo.hs new file mode 100644 --- /dev/null +++ b/programs/TailDemo.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Data.Text as T +import Control.Monad (void) +import Control.Concurrent +import Lens.Micro.TH +import Lens.Micro.Mtl +import System.Random + +import Brick +import Brick.BChan +import Brick.Widgets.Border +import qualified Graphics.Vty as V + +data AppState = + AppState { _textAreaHeight :: Int + , _textAreaWidth :: Int + , _textAreaContents :: [T.Text] + } + +makeLenses ''AppState + +draw :: AppState -> Widget n +draw st = + header st <=> box st + +header :: AppState -> Widget n +header st = + padBottom (Pad 1) $ + hBox [ padRight (Pad 7) $ + (str $ "Max width: " <> show (_textAreaWidth st)) <=> + (str "Left(-)/Right(+)") + , (str $ "Max height: " <> show (_textAreaHeight st)) <=> + (str "Down(-)/Up(+)") + ] + +box :: AppState -> Widget n +box st = + border $ + hLimit (_textAreaWidth st) $ + vLimit (_textAreaHeight st) $ + (renderBottomUp (txtWrap <$> _textAreaContents st)) + +-- | Given a list of widgets, draw them bottom-up in a vertical +-- arrangement, i.e., the first widget in this list will appear at the +-- bottom of the rendering area. Rendering stops when the rendering area +-- is full, i.e., items that cannot be rendered are never evaluated or +-- drawn. +renderBottomUp :: [Widget n] -> Widget n +renderBottomUp ws = + Widget Greedy Greedy $ do + let go _ [] = return V.emptyImage + go remainingHeight (c:cs) = do + cResult <- render c + let img = image cResult + newRemainingHeight = remainingHeight - V.imageHeight img + if newRemainingHeight == 0 + then return img + else if newRemainingHeight < 0 + then return $ V.cropTop remainingHeight img + else do + rest <- go newRemainingHeight cs + return $ V.vertCat [rest, img] + + ctx <- getContext + img <- go (availHeight ctx) ws + render $ fill ' ' <=> raw img + +textLines :: [T.Text] +textLines = + [ "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut" + , "labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco" + , "laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit" + , "in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat" + , "cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." + ] + +handleEvent :: BrickEvent n CustomEvent -> EventM n AppState () +handleEvent (AppEvent (NewLine l)) = + textAreaContents %= (l :) +handleEvent (VtyEvent (V.EvKey V.KUp [])) = + textAreaHeight %= (+ 1) +handleEvent (VtyEvent (V.EvKey V.KDown [])) = + textAreaHeight %= max 0 . subtract 1 +handleEvent (VtyEvent (V.EvKey V.KRight [])) = + textAreaWidth %= (+ 1) +handleEvent (VtyEvent (V.EvKey V.KLeft [])) = + textAreaWidth %= max 0 . subtract 1 +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = + halt +handleEvent _ = + return () + +data CustomEvent = + NewLine T.Text + +app :: App AppState CustomEvent () +app = + App { appDraw = (:[]) . draw + , appChooseCursor = neverShowCursor + , appHandleEvent = handleEvent + , appAttrMap = const $ attrMap V.defAttr [] + , appStartEvent = return () + } + +initialState :: AppState +initialState = + AppState { _textAreaHeight = 20 + , _textAreaWidth = 40 + , _textAreaContents = [] + } + +-- | Run forever, generating new lines of text for the application +-- window, prefixed with a line number. This function simulates the kind +-- of behavior that you'd get from running 'tail -f' on a file. +generateLines :: BChan CustomEvent -> IO () +generateLines chan = go (1::Integer) + where + go lineNum = do + -- Wait a random amount of time (in milliseconds) + let delayOptions = [500, 1000, 2000] + delay <- randomVal delayOptions + threadDelay $ delay * 1000 + + -- Choose a random line of text from our collection + l <- randomVal textLines + + -- Send it to the application to be added to the UI + writeBChan chan $ NewLine $ (T.pack $ "Line " <> show lineNum <> " - ") <> l + + go $ lineNum + 1 + +randomVal :: [a] -> IO a +randomVal as = do + idx <- randomRIO (0, length as - 1) + return $ as !! idx + +main :: IO () +main = do + chan <- newBChan 10 + + -- Run thread to simulate incoming data + void $ forkIO $ generateLines chan + + (_, vty) <- customMainWithDefaultVty (Just chan) app initialState + V.shutdown vty diff --git a/programs/TextWrapDemo.hs b/programs/TextWrapDemo.hs new file mode 100644 --- /dev/null +++ b/programs/TextWrapDemo.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module Main where + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import Brick +import Text.Wrap (defaultWrapSettings, preserveIndentation) + +ui :: Widget () +ui = + t1 <=> (padTop (Pad 1) t2) + where + t1 = strWrap $ "Hello, world! This line is long enough that " <> + "it's likely to wrap on your terminal if your window " <> + "isn't especially wide. Try narrowing and widening " <> + "the window to see what happens to this text." + settings = defaultWrapSettings { preserveIndentation = True } + t2 = strWrapWith settings $ + "This text wraps\n" <> + " with different settings to preserve indentation\n" <> + " so that long lines wrap in nicer way." + +main :: IO () +main = simpleMain ui diff --git a/programs/ThemeDemo.hs b/programs/ThemeDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ThemeDemo.hs @@ -0,0 +1,86 @@ +module Main where + +import Control.Monad (void) +import Control.Monad.State (put) +import Graphics.Vty + ( white, blue, green, yellow, black, magenta + , Event(EvKey) + , Key(KChar, KEsc) + ) + +import Brick.Main +import Brick.Themes + ( Theme + , newTheme + , themeToAttrMap + ) +import Brick.Types + ( Widget + , BrickEvent(VtyEvent) + , EventM + ) +import Brick.Widgets.Center + ( hCenter + , center + ) +import Brick.Widgets.Core + ( (<+>) + , vBox + , str + , hLimit + , withDefAttr + ) +import Brick.Util (on, fg) +import Brick.AttrMap (AttrName, attrName) + +ui :: Widget n +ui = + center $ + hLimit 40 $ + vBox $ hCenter <$> + [ str "Press " <+> (withDefAttr keybindingAttr $ str "1") <+> str " to switch to theme 1." + , str "Press " <+> (withDefAttr keybindingAttr $ str "2") <+> str " to switch to theme 2." + ] + +keybindingAttr :: AttrName +keybindingAttr = attrName "keybinding" + +theme1 :: Theme +theme1 = + newTheme (white `on` blue) + [ (keybindingAttr, fg magenta) + ] + +theme2 :: Theme +theme2 = + newTheme (green `on` black) + [ (keybindingAttr, fg yellow) + ] + +appEvent :: BrickEvent () e -> EventM () Int () +appEvent (VtyEvent (EvKey (KChar '1') [])) = put 1 +appEvent (VtyEvent (EvKey (KChar '2') [])) = put 2 +appEvent (VtyEvent (EvKey (KChar 'q') [])) = halt +appEvent (VtyEvent (EvKey KEsc [])) = halt +appEvent _ = return () + +app :: App Int e () +app = + App { appDraw = const [ui] + , appHandleEvent = appEvent + , appStartEvent = return () + , appAttrMap = \s -> + -- Note that in practice this is not ideal: we don't want + -- 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 + -- show the mechanics of the API. + themeToAttrMap $ if s == 1 + then theme1 + else theme2 + , appChooseCursor = neverShowCursor + } + +main :: IO () +main = void $ defaultMain app 1 diff --git a/programs/ViewportScrollDemo.hs b/programs/ViewportScrollDemo.hs --- a/programs/ViewportScrollDemo.hs +++ b/programs/ViewportScrollDemo.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Applicative import Control.Monad (void) -import Data.Monoid -import Data.Default +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif import qualified Graphics.Vty as V import qualified Brick.Types as T @@ -16,6 +16,9 @@ ( Widget , ViewportType(Horizontal, Vertical, Both) ) +import Brick.AttrMap + ( attrMap + ) import Brick.Widgets.Core ( hLimit , vLimit @@ -25,60 +28,55 @@ , str ) -vp1Name :: T.Name -vp1Name = "demo1" - -vp2Name :: T.Name -vp2Name = "demo2" - -vp3Name :: T.Name -vp3Name = "demo3" +data Name = VP1 + | VP2 + | VP3 + deriving (Ord, Show, Eq) -drawUi :: () -> [Widget] +drawUi :: () -> [Widget Name] drawUi = const [ui] where ui = C.center $ B.border $ hLimit 60 $ vLimit 21 $ vBox [ pair, B.hBorder, singleton ] - singleton = viewport vp3Name Both $ + singleton = viewport VP3 Both $ vBox $ str "Press ctrl-arrow keys to scroll this viewport horizontally and vertically." : (str <$> [ "Line " <> show i | i <- [2..25::Int] ]) - pair = hBox [ viewport vp1Name Vertical $ + pair = hBox [ viewport VP1 Vertical $ vBox $ str "Press up and down arrow keys" : str "to scroll this viewport." : (str <$> [ "Line " <> (show i) | i <- [3..50::Int] ]) , B.vBorder - , viewport vp2Name Horizontal $ + , viewport VP2 Horizontal $ str "Press left and right arrow keys to scroll this viewport." ] -vp1Scroll :: M.ViewportScroll -vp1Scroll = M.viewportScroll vp1Name +vp1Scroll :: M.ViewportScroll Name +vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll -vp2Scroll = M.viewportScroll vp2Name +vp2Scroll :: M.ViewportScroll Name +vp2Scroll = M.viewportScroll VP2 -vp3Scroll :: M.ViewportScroll -vp3Scroll = M.viewportScroll vp3Name +vp3Scroll :: M.ViewportScroll Name +vp3Scroll = M.viewportScroll VP3 -appEvent :: () -> V.Event -> T.EventM (T.Next ()) -appEvent _ (V.EvKey V.KDown [V.MCtrl]) = M.vScrollBy vp3Scroll 1 >> M.continue () -appEvent _ (V.EvKey V.KUp [V.MCtrl]) = M.vScrollBy vp3Scroll (-1) >> M.continue () -appEvent _ (V.EvKey V.KRight [V.MCtrl]) = M.hScrollBy vp3Scroll 1 >> M.continue () -appEvent _ (V.EvKey V.KLeft [V.MCtrl]) = M.hScrollBy vp3Scroll (-1) >> M.continue () -appEvent _ (V.EvKey V.KDown []) = M.vScrollBy vp1Scroll 1 >> M.continue () -appEvent _ (V.EvKey V.KUp []) = M.vScrollBy vp1Scroll (-1) >> M.continue () -appEvent _ (V.EvKey V.KRight []) = M.hScrollBy vp2Scroll 1 >> M.continue () -appEvent _ (V.EvKey V.KLeft []) = M.hScrollBy vp2Scroll (-1) >> M.continue () -appEvent _ (V.EvKey V.KEsc []) = M.halt () -appEvent _ _ = M.continue () +appEvent :: T.BrickEvent Name e -> T.EventM Name () () +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy vp3Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy vp3Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = M.hScrollBy vp3Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = M.hScrollBy vp3Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp1Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp1Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp2Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp2Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () -app :: M.App () V.Event +app :: M.App () e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent - , M.appAttrMap = const def - , M.appLiftVtyEvent = id + , M.appAttrMap = const $ attrMap V.defAttr [] , M.appChooseCursor = M.neverShowCursor } diff --git a/programs/ViewportScrollbarsDemo.hs b/programs/ViewportScrollbarsDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ViewportScrollbarsDemo.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Lens.Micro.TH +import Lens.Micro.Mtl +import Control.Monad (void) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Graphics.Vty as V +import Graphics.Vty.CrossPlatform (mkVty) + +import qualified Brick.Types as T +import qualified Brick.Main as M +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Border as B +import Brick.Types + ( Widget + , ViewportType(Horizontal, Both) + , VScrollBarOrientation(..) + , HScrollBarOrientation(..) + ) +import Brick.Util + ( fg + ) +import Brick.AttrMap + ( AttrMap + , attrMap + ) +import Brick.Widgets.Core + ( Padding(..) + , hLimit + , vLimit + , padRight + , hBox + , vBox + , viewport + , str + , fill + , withVScrollBars + , withHScrollBars + , withHScrollBarRenderer + , withVScrollBarRenderer + , withVScrollBarHandles + , withHScrollBarHandles + , withClickableHScrollBars + , withClickableVScrollBars + , VScrollbarRenderer(..) + , HScrollbarRenderer(..) + , scrollbarAttr + , scrollbarHandleAttr + ) + +customHScrollbars :: HScrollbarRenderer n +customHScrollbars = + HScrollbarRenderer { renderHScrollbar = vLimit 1 $ fill '^' + , renderHScrollbarTrough = vLimit 1 $ fill ' ' + , renderHScrollbarHandleBefore = str "<<" + , renderHScrollbarHandleAfter = str ">>" + , scrollbarHeightAllocation = 2 + } + +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 | SBClick T.ClickableScrollbarElement Name + deriving (Ord, Show, Eq) + +data St = St { _lastClickedElement :: Maybe (T.ClickableScrollbarElement, Name) } + +makeLenses ''St + +drawUi :: St -> [Widget Name] +drawUi st = [ui] + where + 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) $ + B.border $ + withClickableHScrollBars SBClick $ + withHScrollBars OnBottom $ + 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 $ + withClickableVScrollBars SBClick $ + withVScrollBars OnLeft $ + withVScrollBarRenderer customVScrollbars $ + withVScrollBarHandles $ + viewport VP2 Both $ + vBox $ + (str $ unlines $ + [ "Press up and down arrow keys to" + , "scroll this viewport vertically." + , "This viewport uses a custom" + , "scroll bar renderer with" + , "a larger space allocation and" + , "even more fancy rendering." + ]) + : (str <$> [ "Line " <> show i | i <- [2..55::Int] ]) + ] + +vp1Scroll :: M.ViewportScroll Name +vp1Scroll = M.viewportScroll VP1 + +vp2Scroll :: M.ViewportScroll Name +vp2Scroll = M.viewportScroll VP2 + +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp1Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp1Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp2Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp2Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent (T.MouseDown (SBClick el n) _ _ _) = do + lastClickedElement .= Just (el, n) + case n of + VP1 -> do + let vp = M.viewportScroll VP1 + case el of + T.SBHandleBefore -> M.hScrollBy vp (-1) + T.SBHandleAfter -> M.hScrollBy vp 1 + T.SBTroughBefore -> M.hScrollBy vp (-10) + T.SBTroughAfter -> M.hScrollBy vp 10 + T.SBBar -> return () + VP2 -> do + let vp = M.viewportScroll VP2 + 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 () +appEvent _ = return () + +theme :: AttrMap +theme = + attrMap V.defAttr + [ (scrollbarAttr, fg V.white) + , (scrollbarHandleAttr, fg V.brightYellow) + ] + +app :: M.App St e Name +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = return () + , M.appHandleEvent = appEvent + , M.appAttrMap = const theme + , M.appChooseCursor = M.neverShowCursor + } + +main :: IO () +main = do + let buildVty = do + v <- mkVty V.defaultConfig + V.setMode (V.outputIface v) V.Mouse True + return v + + initialVty <- buildVty + void $ M.customMain initialVty buildVty Nothing app (St Nothing) diff --git a/programs/VisibilityDemo.hs b/programs/VisibilityDemo.hs --- a/programs/VisibilityDemo.hs +++ b/programs/VisibilityDemo.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module Main where import Control.Monad (void) -import Control.Lens +import Lens.Micro +import Lens.Micro.TH +import Lens.Micro.Mtl +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid +#endif import qualified Graphics.Vty as V import qualified Brick.Types as T import qualified Brick.Main as M import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B -import Brick.AttrMap (AttrMap, AttrName, attrMap) +import Brick.AttrMap (AttrMap, AttrName, attrMap, attrName) import Brick.Util (on) import Brick.Types ( Widget @@ -36,28 +40,24 @@ makeLenses ''St -vp1Name :: T.Name -vp1Name = "demo1" +data Name = VP1 + | VP2 + | VP3 + deriving (Show, Ord, Eq) vp1Size :: Int vp1Size = 15 -vp2Name :: T.Name -vp2Name = "demo2" - vp2Size :: Int vp2Size = 15 -vp3Name :: T.Name -vp3Name = "demo3" - vp3Size :: (Int, Int) vp3Size = (25, 25) selectedAttr :: AttrName -selectedAttr = "selected" +selectedAttr = attrName "selected" -drawUi :: St -> [Widget] +drawUi :: St -> [Widget Name] drawUi st = [ui] where ui = C.center $ hLimit 60 $ vLimit 30 $ @@ -66,7 +66,7 @@ "- Left/right arrow keys scroll the top-right viewport\n" <> "- Ctrl-arrow keys move the bottom viewport" ] - singleton = viewport vp3Name Both $ + singleton = viewport VP3 Both $ vBox $ do i <- [1..vp3Size^._1] let row = do @@ -78,14 +78,14 @@ return $ hBox row pair = hBox [ vp1, B.vBorder, vp2 ] - vp1 = viewport vp1Name Vertical $ + vp1 = viewport VP1 Vertical $ vBox $ do i <- [1..vp1Size] let mkItem = if i == st^.vp1Index then withAttr selectedAttr . visible else id return $ mkItem $ str $ "Item " <> show i - vp2 = viewport vp2Name Horizontal $ + vp2 = viewport VP2 Horizontal $ hBox $ do i <- [1..vp2Size] let mkItem = if i == st^.vp2Index @@ -93,39 +93,38 @@ else id return $ mkItem $ str $ "Item " <> show i <> " " -vp1Scroll :: M.ViewportScroll -vp1Scroll = M.viewportScroll vp1Name +vp1Scroll :: M.ViewportScroll Name +vp1Scroll = M.viewportScroll VP1 -vp2Scroll :: M.ViewportScroll -vp2Scroll = M.viewportScroll vp2Name +vp2Scroll :: M.ViewportScroll Name +vp2Scroll = M.viewportScroll VP2 -vp3Scroll :: M.ViewportScroll -vp3Scroll = M.viewportScroll vp3Name +vp3Scroll :: M.ViewportScroll Name +vp3Scroll = M.viewportScroll VP3 -appEvent :: St -> V.Event -> T.EventM (T.Next St) -appEvent st (V.EvKey V.KDown [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ min (vp3Size^._1) . (+ 1) -appEvent st (V.EvKey V.KUp [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ max 1 . subtract 1 -appEvent st (V.EvKey V.KRight [V.MCtrl]) = M.continue $ st & vp3Index._2 %~ min (vp3Size^._1) . (+ 1) -appEvent st (V.EvKey V.KLeft [V.MCtrl]) = M.continue $ st & vp3Index._2 %~ max 1 . subtract 1 -appEvent st (V.EvKey V.KDown []) = M.continue $ st & vp1Index %~ min vp1Size . (+ 1) -appEvent st (V.EvKey V.KUp []) = M.continue $ st & vp1Index %~ max 1 . subtract 1 -appEvent st (V.EvKey V.KRight []) = M.continue $ st & vp2Index %~ min vp2Size . (+ 1) -appEvent st (V.EvKey V.KLeft []) = M.continue $ st & vp2Index %~ max 1 . subtract 1 -appEvent st (V.EvKey V.KEsc []) = M.halt st -appEvent st _ = M.continue st +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = vp3Index._1 %= min (vp3Size^._1) . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = vp3Index._1 %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = vp3Index._2 %= min (vp3Size^._1) . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = vp3Index._2 %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = vp1Index %= min vp1Size . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = vp1Index %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = vp2Index %= min vp2Size . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = vp2Index %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () theMap :: AttrMap theMap = attrMap V.defAttr [ (selectedAttr, V.black `on` V.yellow) ] -app :: M.App St V.Event +app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const theMap - , M.appLiftVtyEvent = id , M.appChooseCursor = M.neverShowCursor } diff --git a/programs/custom_keys.ini b/programs/custom_keys.ini new file mode 100644 --- /dev/null +++ b/programs/custom_keys.ini @@ -0,0 +1,4 @@ +[keybindings] +quit = x +increment = i +decrement = d diff --git a/src/Brick.hs b/src/Brick.hs --- a/src/Brick.hs +++ b/src/Brick.hs @@ -1,5 +1,11 @@ -- | This module is provided as a convenience to import the most --- important parts of the API all at once. +-- 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). +-- 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 +-- referring to the API docs only as needed. Enjoy! module Brick ( module Brick.Main , module Brick.Types diff --git a/src/Brick/Animation.hs b/src/Brick/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Animation.hs @@ -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 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 diff --git a/src/Brick/Animation/Clock.hs b/src/Brick/Animation/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Animation/Clock.hs @@ -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 diff --git a/src/Brick/AttrMap.hs b/src/Brick/AttrMap.hs --- a/src/Brick/AttrMap.hs +++ b/src/Brick/AttrMap.hs @@ -1,8 +1,7 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} -- | This module provides types and functions for managing an attribute -- map which maps attribute names ('AttrName') to attributes ('Attr'). --- This module is designed to be used with the 'OverloadedStrings' --- language extension to permit easy construction of 'AttrName' values --- and you should also use 'mappend' ('<>') to combine names. -- -- Attribute maps work by mapping hierarchical attribute names to -- attributes and inheriting parent names' attributes when child names @@ -15,7 +14,7 @@ -- Attribute names are mapped to attributes, but some attributes may -- be partial (specify only a foreground or background color). When -- attribute name lookups occur, the attribute corresponding to a more --- specific name ('parent <> child' as above) is sucessively merged with +-- specific name ('parent <> child' as above) is successively merged with -- the parent attribute ('parent' as above) all the way to the "root" -- of the attribute map, the map's default attribute. In this way, more -- specific attributes inherit what they don't specify from more general @@ -28,63 +27,69 @@ -- * Construction , attrMap , forceAttrMap + , forceAttrMapAllowStyle , attrName + -- * Inspection + , attrNameComponents -- * Finding attributes from names , attrMapLookup -- * Manipulating attribute maps - , setDefault + , setDefaultAttr + , getDefaultAttr , applyAttrMappings , mergeWithDefault + , mapAttrName + , mapAttrNames ) where -import Control.Applicative ((<$>)) +import qualified Data.Semigroup as Sem + +import Control.DeepSeq +import Data.Bits ((.|.)) import qualified Data.Map as M -import Data.Monoid -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.List (inits) -import Data.String (IsString(..)) -import Data.Default (Default(..)) +import GHC.Generics (Generic) -import Graphics.Vty (Attr(..), MaybeDefault(..)) +import Graphics.Vty (Attr(..), MaybeDefault(..), Style) -- | An attribute name. Attribute names are hierarchical; use 'mappend' --- ('<>') to assemble them. Hierachy in an attribute name is used to +-- ('<>') to assemble them. Hierarchy in an attribute name is used to -- represent increasing levels of specificity in referring to the -- attribute you want to use for a visual element, with names to the -- left being general and names to the right being more specific. For -- example: -- -- @ --- "window" <> "border" --- "window" <> "title" --- "header" <> "clock" <> "seconds" +-- attrName "window" <> attrName "border" +-- attrName "window" <> attrName "title" +-- attrName "header" <> attrName "clock" <> attrName "seconds" -- @ data AttrName = AttrName [String] - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord, Generic, NFData) -instance Default AttrName where - def = mempty +instance Sem.Semigroup AttrName where + (AttrName as) <> (AttrName bs) = AttrName $ as `mappend` bs instance Monoid AttrName where mempty = AttrName [] - mappend (AttrName as) (AttrName bs) = AttrName $ as `mappend` bs - -instance IsString AttrName where - fromString = AttrName . (:[]) + mappend = (Sem.<>) -- | An attribute map which maps 'AttrName' values to 'Attr' values. data AttrMap = AttrMap Attr (M.Map AttrName Attr) | ForceAttr Attr - deriving Show - -instance Default AttrMap where - def = AttrMap def mempty + | ForceAttrAllowStyle Attr AttrMap + deriving (Show, Generic, NFData) -- | Create an attribute name from a string. attrName :: String -> AttrName attrName = AttrName . (:[]) +-- | Get the components of an attribute name. +attrNameComponents :: AttrName -> [String] +attrNameComponents (AttrName cs) = cs + -- | Create an attribute map. attrMap :: Attr -- ^ The map's default attribute to be returned when a name @@ -96,10 +101,15 @@ attrMap theDefault pairs = AttrMap theDefault (M.fromList pairs) -- | Create an attribute map in which all lookups map to the same --- attribute. +-- attribute. This is functionally equivalent to @attrMap attr []@. 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 @@ -119,50 +129,92 @@ -- @ 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 -- proceed as follows. If the attribute map is forcing all lookups to a --- specific attribute, that attribute is returned. If the attribute name --- is empty, the map's default attribute is returned. If the attribute --- name is non-empty, very subsequence of names from the specified name --- are used to perform a lookup, and the results are combined as in --- 'mergeWithDefault', with more specific results taking precedence over --- less specific ones. +-- specific attribute, that attribute is returned along with its style +-- settings. If the attribute name is empty, the map's default attribute +-- is returned. If the attribute name is non-empty, every subsequence of +-- names from the specified name are used to perform a lookup and the +-- results are combined as in 'mergeWithDefault', with more specific +-- results taking precedence over less specific ones. As attributes are +-- merged, styles are also merged. If a more specific attribute name +-- introduces a style (underline, say) and a less specific attribute +-- name introduces an additional style (bold, say) then the final result +-- will include both styles. -- -- For example: -- -- @ --- attrMapLookup ("foo" <> "bar") (attrMap a []) == a --- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo" <> "bar", fg red)]) == red \`on\` blue --- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo" <> "bar", red `on` cyan)]) == red \`on\` cyan --- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo" <> "bar", fg red), ("foo", bg cyan)]) == red \`on\` cyan --- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo", fg red)]) == red \`on\` blue +-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap a []) == a +-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo" <> attrName "bar", fg red)]) == red \`on\` blue +-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo" <> attrName "bar", red `on` cyan)]) == red \`on\` cyan +-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo" <> attrName "bar", fg red), ("foo", bg cyan)]) == red \`on\` cyan +-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo", fg red)]) == red \`on\` blue -- @ 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 = catMaybes $ (\n -> M.lookup n m) <$> (AttrName <$> (inits ns)) + let results = mapMaybe (\n -> M.lookup (AttrName n) m) (inits ns) in foldl combineAttrs theDefault results -- | Set the default attribute value in an attribute map. -setDefault :: Attr -> AttrMap -> AttrMap -setDefault _ (ForceAttr a) = ForceAttr a -setDefault newDefault (AttrMap _ m) = AttrMap newDefault m +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 -combineAttrs (Attr s1 f1 b1) (Attr s2 f2 b2) = - Attr (s1 `combineMDs` s2) +combineAttrs (Attr s1 f1 b1 u1) (Attr s2 f2 b2 u2) = + Attr (s1 `combineStyles` s2) (f1 `combineMDs` f2) (b1 `combineMDs` b2) + (u1 `combineMDs` u2) combineMDs :: MaybeDefault a -> MaybeDefault a -> MaybeDefault a combineMDs _ (SetTo v) = SetTo v combineMDs (SetTo v) _ = SetTo v combineMDs _ v = v +combineStyles :: MaybeDefault Style -> MaybeDefault Style -> MaybeDefault Style +combineStyles (SetTo a) (SetTo b) = SetTo $ a .|. b +combineStyles _ (SetTo v) = SetTo v +combineStyles (SetTo v) _ = SetTo v +combineStyles _ v = v + -- | Insert a set of attribute mappings to an attribute map. 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 +-- composite widgets with specific attribute names mapping those names +-- to the sub-widget's expected name when calling that sub-widget's +-- rendering function. See the ProgressBarDemo for an example usage, +-- and 'overrideAttr' for an alternate syntax. +mapAttrName :: AttrName -> AttrName -> AttrMap -> AttrMap +mapAttrName fromName ontoName inMap = + applyAttrMappings [(ontoName, attrMapLookup fromName inMap)] inMap + +-- | Map several attributes to return the value associated with an +-- alternate name. Applies 'mapAttrName' across a list of mappings. +mapAttrNames :: [(AttrName, AttrName)] -> AttrMap -> AttrMap +mapAttrNames names inMap = foldr (uncurry mapAttrName) inMap names diff --git a/src/Brick/BChan.hs b/src/Brick/BChan.hs new file mode 100644 --- /dev/null +++ b/src/Brick/BChan.hs @@ -0,0 +1,44 @@ +module Brick.BChan + ( BChan + , newBChan + , writeBChan + , writeBChanNonBlocking + , readBChan + , readBChan2 + ) +where + +import Control.Concurrent.STM.TBQueue +import Control.Monad.STM (atomically, orElse) + +-- | @BChan@ is an abstract type representing a bounded FIFO channel. +data BChan a = BChan (TBQueue a) + +-- | Builds and returns a new instance of @BChan@. +newBChan :: Int -- ^ maximum number of elements the channel can hold + -> IO (BChan a) +newBChan size = atomically $ BChan <$> newTBQueue (fromIntegral size) + +-- | Writes a value to a @BChan@; blocks if the channel is full. +writeBChan :: BChan a -> a -> IO () +writeBChan (BChan q) a = atomically $ writeTBQueue q a + +-- | Attempts to write a value to a @BChan@. If the channel has room, +-- the value is written and this returns 'True'. Otherwise this returns +-- 'False' and returns immediately. +writeBChanNonBlocking :: BChan a -> a -> IO Bool +writeBChanNonBlocking (BChan q) a = atomically $ do + f <- isFullTBQueue q + if f + then return False + else writeTBQueue q a >> return True + +-- | Reads the next value from the @BChan@; blocks if necessary. +readBChan :: BChan a -> IO a +readBChan (BChan q) = atomically $ readTBQueue q + +-- | Reads the next value from either @BChan@, prioritizing the first +-- @BChan@; blocks if necessary. +readBChan2 :: BChan a -> BChan b -> IO (Either a b) +readBChan2 (BChan q1) (BChan q2) = atomically $ + (Left <$> readTBQueue q1) `orElse` (Right <$> readTBQueue q2) diff --git a/src/Brick/BorderMap.hs b/src/Brick/BorderMap.hs new file mode 100644 --- /dev/null +++ b/src/Brick/BorderMap.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +module Brick.BorderMap + ( BorderMap + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL + , empty, clear, emptyCoordinates, singleton + , insertH, insertV, insert + , unsafeUnion + , coordinates, bounds + , values + , lookupRow, lookupCol, lookupH, lookupV, lookup + , setCoordinates, crop, expand + , translate + ) 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 +import Prelude hiding (lookup) +import qualified Data.IMap as IM + +-- | Internal use only. +neighbors :: Edges a -> Edges (a, a) +neighbors (Edges vt vb vl vr) = Edges horiz horiz vert vert where + horiz = (vl, vr) + vert = (vt, vb) + +-- Invariant: corner values are present on all the edges incident on that +-- corner. Widthless or heightless rectangles replicate the IMaps exactly on +-- the two coincident edges. +-- +-- Practically speaking, this means for lookup you can look on any edge that +-- could contain the key you care about, while for insertion you must insert on +-- every edge that could contain the keys being inserted. + +-- | A @BorderMap a@ is like a @Map Location a@, except that there is a +-- rectangle, and only 'Location's on the border of this rectangle are +-- retained. The 'BorderMap' can be queried for the position and size of the +-- rectangle. There are also efficient bulk query and bulk update operations +-- for adjacent positions on the border. +data BorderMap a = BorderMap + { _coordinates :: Edges Int + , _values :: Edges (IMap a) + } deriving (Eq, Ord, Show, Functor, Read, Generic, NFData) + +-- | Given a rectangle (specified as the coordinates of the top, left, bottom, +-- and right sides), initialize an empty 'BorderMap'. +emptyCoordinates :: Edges Int -> BorderMap a +emptyCoordinates cs = BorderMap { _coordinates = cs, _values = pure IM.empty } + +-- | An empty 'BorderMap' that tracks the same points as the input. +clear :: BorderMap a -> BorderMap b +clear = emptyCoordinates . coordinates + +-- | An empty 'BorderMap' that does not track any points. +empty :: BorderMap a +empty = emptyCoordinates Edges + { eTop = 0 + , eBottom = -1 + , eLeft = 0 + , eRight = -1 + } + +-- | A 'BorderMap' that tracks only the given the point (and initially maps it +-- to the given value). +singleton :: Location -> a -> BorderMap a +singleton l v = translate l . insert origin v . emptyCoordinates $ pure 0 + +{-# INLINE coordinates #-} +-- | The positions of the edges of the rectangle whose border is retained in a +-- 'BorderMap'. For example, if @coordinates m = e@, then the top border +-- contains the 'Location's on row @eTop e@ and between columns @eLeft e@ to +-- @eRight e@ inclusive. +coordinates :: BorderMap a -> Edges Int +coordinates = _coordinates + +-- | A complementary way to query the edges of the rectangle whose border is +-- retained in a 'BorderMap'. For example, if @bounds m = b@, then a +-- 'Location'\'s column must be between @fst (eTop b)@ and @snd (eTop b)@ to be +-- retained. See also 'coordinates', which is in most cases a more natural +-- border query. +bounds :: BorderMap a -> Edges (Int, Int) +bounds = neighbors . coordinates + +{-# INLINE values #-} +-- | Maps giving the values along each edge. Corner values are replicated in +-- all relevant edges. +values :: BorderMap a -> Edges (IMap a) +values = _values + +-- | Bulk insertion of horizontally-adjacent values. The 'Location' gives the +-- start point, and the 'Run' extends in the "larger columns" direction. +insertH :: Location -> Run a -> BorderMap a -> BorderMap a +insertH = insertDirAgnostic (Edges insertPar insertPar insertPerp insertPerp) . swapLoc + where + swapLoc (Location (col, row)) = Location (row, col) + +-- | Bulk insertion of vertically-adjacent values. The 'Location' gives the +-- start point, and the 'Run' extends in the "larger rows" direction. +insertV :: Location -> Run a -> BorderMap a -> BorderMap a +insertV = insertDirAgnostic (Edges insertPerp insertPerp insertPar insertPar) + +insertDirAgnostic + :: Edges (Location -> Run a -> Int -> (Int, Int) -> IMap a -> IMap a) + -> Location -> Run a -> BorderMap a -> BorderMap a +insertDirAgnostic insertions l r m = + m { _values = insertions <*> pure l <*> pure r <*> coordinates m <*> bounds m <*> _values m } + +insertPar, insertPerp :: Location -> Run a -> Int -> (Int, Int) -> IMap a -> IMap a +insertPar (Location (kPar, kPerp)) r herePar (loPerp, hiPerp) + | kPar == herePar && loPerp <= kPerp + IM.len r - 1 && kPerp <= hiPerp + = IM.insert beg r { IM.len = end - beg + 1 } + | otherwise = id + where + beg = max kPerp loPerp + end = min (kPerp + IM.len r - 1) hiPerp +insertPerp (Location (kPar, kPerp)) r herePerp (loPar, hiPar) + | loPar <= kPar && kPar <= hiPar && kPerp <= herePerp && herePerp <= kPerp + IM.len r - 1 + = IM.insert kPar r { IM.len = 1 } + | otherwise = id + +-- | Insert a single value at the given location. +insert :: Location -> a -> BorderMap a -> BorderMap a +insert l = insertV l . Run 1 + +-- | Look up all values on a given row. The 'IMap' returned maps columns to +-- values. +lookupRow :: Int -> BorderMap a -> IMap a +lookupRow row m + | row == eTop (coordinates m) = eTop (_values m) + | row == eBottom (coordinates m) = eBottom (_values m) + | otherwise = IM.fromList + $ [(eLeft (coordinates m), Run 1 a) | Just a <- [IM.lookup row (eLeft (_values m))]] + ++ [(eRight (coordinates m), Run 1 a) | Just a <- [IM.lookup row (eRight (_values m))]] + +-- | Look up all values on a given column. The 'IMap' returned maps rows to +-- values. +lookupCol :: Int -> BorderMap a -> IMap a +lookupCol col m + | col == eLeft (coordinates m) = eLeft (_values m) + | col == eRight (coordinates m) = eRight (_values m) + | otherwise = IM.fromList + $ [(eTop (coordinates m), Run 1 a) | Just a <- [IM.lookup col (eTop (_values m))]] + ++ [(eBottom (coordinates m), Run 1 a) | Just a <- [IM.lookup col (eBottom (_values m))]] + +-- | Bulk lookup of horizontally-adjacent values. The 'Location' gives the +-- starting point, and the 'Run' extends in the "larger columns" direction. The +-- 'IMap' returned maps columns to values. +lookupH :: Location -> Run ignored -> BorderMap a -> IMap a +lookupH (Location (col, row)) r = IM.restrict col r . lookupRow row + +-- | Bulk lookup of vertically-adjacent values. The 'Location' gives the +-- starting point, and the 'Run' extends in the "larger rows" direction. The +-- 'IMap' returned maps rows to values. +lookupV :: Location -> Run ignored -> BorderMap a -> IMap a +lookupV (Location (col, row)) r = IM.restrict row r . lookupCol col + +-- | Look up a single position. +lookup :: Location -> BorderMap a -> Maybe a +lookup (Location (col, row)) = IM.lookup row . lookupCol col + +-- | Set the rectangle being tracked by this 'BorderMap', throwing away any +-- values that do not lie on this new rectangle. +setCoordinates :: Edges Int -> BorderMap a -> BorderMap a +setCoordinates coordinates' m = BorderMap + { _values = values' + , _coordinates = coordinates' + } + where + bounds' = neighbors coordinates' + values' = gc + <$> _coordinates m + <*> coordinates' + <*> bounds' + <*> _values m + <*> Edges { eTop = lookupRow, eBottom = lookupRow, eLeft = lookupCol, eRight = lookupCol } + gc oldPar newPar (loPerp, hiPerp) imPar lookupPerp + | oldPar == newPar = IM.restrict loPerp (Run (hiPerp-loPerp+1) ()) imPar + | otherwise = lookupPerp newPar m + +-- | Ensure that the rectangle being tracked by this 'BorderMap' extends no +-- farther than the given one. +crop :: Edges Int -> BorderMap a -> BorderMap a +crop cs m = setCoordinates (shrink <*> cs <*> coordinates m) m where + shrink = Edges + { eTop = max + , eBottom = min + , eLeft = max + , eRight = min + } + +-- | Ensure that the rectangle being tracked by this 'BorderMap' extends at +-- least as far as the given one. +expand :: Edges Int -> BorderMap a -> BorderMap a +expand cs m = setCoordinates (grow <*> cs <*> coordinates m) m where + grow = Edges + { eTop = min + , eBottom = max + , eLeft = min + , eRight = max + } + +-- | Move a 'BorderMap' by adding the given 'Location' to all keys in the map. +translate :: Location -> BorderMap a -> BorderMap a +-- fast path: do nothing for (0,0) +translate (Location (0, 0)) m = m +translate (Location (c, r)) m = BorderMap + { _coordinates = liftA2 (+) cOffsets (_coordinates m) + , _values = liftA2 IM.addToKeys vOffsets (_values m) + } + where + cOffsets = Edges { eTop = r, eBottom = r, eLeft = c, eRight = c } + vOffsets = Edges { eTop = c, eBottom = c, eLeft = r, eRight = r } + +-- | Assumes the two 'BorderMap's are tracking the same rectangles, but have +-- disjoint keys. This property is not checked. +unsafeUnion :: BorderMap a -> BorderMap a -> BorderMap a +unsafeUnion m m' = m { _values = liftA2 IM.unsafeUnion (_values m) (_values m') } diff --git a/src/Brick/Focus.hs b/src/Brick/Focus.hs --- a/src/Brick/Focus.hs +++ b/src/Brick/Focus.hs @@ -1,68 +1,112 @@ -- | This module provides a type and functions for handling focus rings --- of widgets. Note that this interface is merely provided for managing --- the focus state for a sequence of widget names; it does not do --- anything beyond keep track of that. --- --- This interface is experimental. +-- of values. module Brick.Focus ( FocusRing , focusRing , focusNext , focusPrev , focusGetCurrent + , focusSetCurrent + , focusRingLength + , focusRingToList , focusRingCursor + , withFocusRing + , focusRingModify ) where -import Control.Lens ((^.)) -import Data.Maybe (listToMaybe) +import Lens.Micro ((^.)) +import Data.List (find) +import qualified Data.CircularList as C import Brick.Types +import Brick.Widgets.Core (Named(..)) --- | A focus ring containing a sequence of widget names to focus and a --- currently-focused widget name. -data FocusRing = FocusRingEmpty - | FocusRingNonempty ![Name] !Int +-- | 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 names. -focusRing :: [Name] -> FocusRing -focusRing [] = FocusRingEmpty -focusRing names = FocusRingNonempty names 0 +-- | Construct a focus ring from the list of resource names. +focusRing :: [n] -> FocusRing n +focusRing = FocusRing . C.fromList --- | Advance focus to the next widget in the ring. -focusNext :: FocusRing -> FocusRing -focusNext FocusRingEmpty = FocusRingEmpty -focusNext (FocusRingNonempty ns i) = FocusRingNonempty ns i' - where - i' = (i + 1) `mod` (length ns) +-- | Advance focus to the next value in the ring. +focusNext :: FocusRing n -> FocusRing n +focusNext r@(FocusRing l) + | C.isEmpty l = r + | otherwise = FocusRing $ C.rotR l --- | Advance focus to the previous widget in the ring. -focusPrev :: FocusRing -> FocusRing -focusPrev FocusRingEmpty = FocusRingEmpty -focusPrev (FocusRingNonempty ns i) = FocusRingNonempty ns i' - where - i' = (i + (length ns) - 1) `mod` (length ns) +-- | Advance focus to the previous value in the ring. +focusPrev :: FocusRing n -> FocusRing n +focusPrev r@(FocusRing l) + | C.isEmpty l = r + | otherwise = FocusRing $ C.rotL l --- | Get the currently-focused widget name from the ring. If the ring is --- emtpy, return 'Nothing'. -focusGetCurrent :: FocusRing -> Maybe Name -focusGetCurrent FocusRingEmpty = Nothing -focusGetCurrent (FocusRingNonempty ns i) = Just $ ns !! i +-- | This function is a convenience function to look up a widget state +-- value's resource name in a focus ring and set its focus setting +-- according to the focus ring's state. This function determines whether +-- a given widget state value is the focus of the ring and passes the +-- resulting boolean to a rendering function, along with the state value +-- (a), to produce whatever comes next (b). +-- +-- Focus-aware widgets have rendering functions that should be +-- usable with this combinator; see 'Brick.Widgets.List.List' and +-- 'Brick.Widgets.Edit.Edit'. +withFocusRing :: (Eq n, Named a n) + => FocusRing n + -- ^ The focus ring to use as the source of focus state. + -> (Bool -> a -> b) + -- ^ A function that takes a value and its focus state. + -> a + -- ^ The widget state value that we need to check for focus. + -> b + -- ^ The rest of the computation. +withFocusRing ring f a = f (focusGetCurrent ring == Just (getName a)) a +-- | Get the currently-focused resource name from the ring. If the ring +-- is empty, return 'Nothing'. +focusGetCurrent :: FocusRing n -> Maybe n +focusGetCurrent (FocusRing l) = C.focus l + +-- | Set the currently-focused resource name in the ring, provided the +-- name is in the ring. Otherwise return the ring unmodified. +focusSetCurrent :: (Eq n) => n -> FocusRing n -> FocusRing n +focusSetCurrent n r@(FocusRing l) = + case C.rotateTo n l of + Nothing -> r + Just l' -> FocusRing l' + +-- | Get the size of the FocusRing. +focusRingLength :: FocusRing n -> Int +focusRingLength (FocusRing l) = C.size l + +-- | Return all of the entries in the focus ring, starting with the +-- currently-focused entry and wrapping around the ring. +-- +-- For example, if a ring contains A, B, C, and D, and the current entry +-- is B, the result will be [B, C, D, A]. +focusRingToList :: FocusRing n -> [n] +focusRingToList (FocusRing l) = C.rightElements l + +-- | Modify the internal circular list structure of a focus ring +-- directly. This function permits modification of the circular list +-- using the rich Data.CircularList API. +focusRingModify :: (C.CList n -> C.CList n) -> FocusRing n -> FocusRing n +focusRingModify f (FocusRing l) = FocusRing $ f l + -- | Cursor selection convenience function for use as an -- 'Brick.Main.appChooseCursor' value. -focusRingCursor :: (a -> FocusRing) +focusRingCursor :: (Eq n) + => (a -> FocusRing n) -- ^ The function used to get the focus ring out of your -- application state. -> a -- ^ Your application state. - -> [CursorLocation] + -> [CursorLocation n] -- ^ The list of available cursor positions. - -> Maybe CursorLocation - -- ^ The cursor position, if any, that matches the name - -- currently focused by the 'FocusRing'. -focusRingCursor getRing st ls = - listToMaybe $ filter isCurrent ls - where - isCurrent cl = cl^.cursorLocationNameL == - (focusGetCurrent $ getRing st) + -> Maybe (CursorLocation n) + -- ^ The cursor position, if any, that matches the + -- resource name currently focused by the 'FocusRing'. +focusRingCursor getRing st = find $ \cl -> + cl^.cursorLocationNameL == focusGetCurrent (getRing st) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Forms.hs @@ -0,0 +1,970 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +-- | Note - this API is designed to support a narrow (but common!) set +-- of use cases. If you find that you need more customization than this +-- offers, then you will need to consider building your own layout and +-- event handling for input fields. +-- +-- For a fuller introduction to this API, see the "Input Forms" section +-- of the Brick User Guide. Also see the demonstration programs for +-- examples of forms in action. +-- +-- This module provides an input form API. This API allows you to +-- construct an input interface based on a data type of your choice. +-- Each input in the form corresponds to a field in your data type. This +-- API then automatically dispatches keyboard and mouse input events to +-- each form input field, manages rendering of the form, notifies the +-- user when a form field's value is invalid, and stores valid inputs in +-- your data type when possible. +-- +-- A form has both a visual representation and a corresponding data +-- structure representing the latest valid values for that form +-- (referred to as the "state" of the form). A 'FormField' is a single +-- input component in the form and a 'FormFieldState' defines the +-- linkage between that visual input and the corresponding portion +-- of the state represented by that visual; there may be multiple +-- 'FormField's combined for a single 'FormFieldState' (e.g. a radio +-- button sequence). +-- +-- To use a 'Form', you must include it within your application state +-- type. You can use 'formState' to access the underlying state whenever +-- you need it. See @programs/FormDemo.hs@ for a complete working +-- example. +-- +-- Also note that, by default, forms and their field inputs are +-- concatenated together in a 'vBox'. This can be customized on a +-- per-field basis and for the entire form by using the functions +-- 'setFieldConcat' and 'setFormConcat', respectively. +-- +-- Bear in mind that for most uses, the 'FormField' and 'FormFieldState' +-- types will not be used directly. Instead, the constructors for +-- various field types (such as 'editTextField') will be used instead. +module Brick.Forms + ( -- * Data types + Form + , FormFieldState(..) + , FormField(..) + , FormFieldVisibilityMode(..) + + -- * Creating and using forms + , newForm + , formFocus + , formState + , handleFormEvent + , renderForm + , renderFormFieldState + , (@@=) + , allFieldsValid + , invalidFields + , setFieldValid + , setFormConcat + , setFieldConcat + , setFormFocus + , updateFormState + , setFieldVisibilityMode + + -- * Simple form field constructors + , editTextField + , editShowableField + , editShowableFieldWithValidate + , editPasswordField + , radioField + , checkboxField + , listField + + -- * Advanced form field constructors + , editField + , radioCustomField + , checkboxCustomField + + -- * Attributes + , formAttr + , invalidFormInputAttr + , focusedFormInputAttr + ) +where + +import Graphics.Vty hiding (showCursor) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import Data.Maybe (fromJust, isJust, isNothing) +import Data.List (elemIndex) +import Data.Vector (Vector) + +import Brick +import Brick.Focus +import Brick.Widgets.Edit +import Brick.Widgets.List +import qualified Data.Text.Zipper as Z + +import qualified Data.Text as T +import Text.Read (readMaybe) + +import Lens.Micro +import Lens.Micro.Mtl + +-- | A form field. This represents an interactive input field in the +-- form. Its user input is validated and thus converted into a type of +-- your choosing. +-- +-- Type variables are as follows: +-- +-- * @a@ - the type of the field in your form state that this field +-- manipulates +-- * @b@ - the form field's internal state type +-- * @e@ - your application's event type +-- * @n@ - your application's resource name type +data FormField a b e n = + FormField { formFieldName :: n + -- ^ The name identifying this form field. + , formFieldValidate :: b -> Maybe a + -- ^ A validation function converting this field's state + -- into a value of your choosing. @Nothing@ indicates a + -- validation failure. For example, this might validate + -- an 'Editor' state value by parsing its text contents as + -- an integer and return 'Maybe' 'Int'. This is for pure + -- value validation; if additional validation is required + -- (e.g. via 'IO'), use this field's state value in an + -- external validation routine and use 'setFieldValid' to + -- feed the result back into the form. + , formFieldExternallyValid :: Bool + -- ^ Whether the field is valid according to an external + -- validation source. Defaults to always being 'True' and + -- can be set with 'setFieldValid'. The value of this + -- field also affects the behavior of 'allFieldsValid' and + -- 'getInvalidFields'. + , formFieldRender :: Bool -> b -> Widget n + -- ^ A function to render this form field. Parameters are + -- whether the field is currently focused, followed by the + -- field state. + , formFieldHandleEvent :: BrickEvent n e -> EventM n b () + -- ^ 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 +-- maps that state field (using a lens into your state) to the form +-- input fields responsible for managing that state field, along with +-- a current value for that state field and an optional function to +-- control how the form inputs are rendered. +-- +-- Most form fields will just have one input, such as text editors, but +-- others, such as radio button collections, will have many, which is +-- why this type supports more than one input corresponding to a state +-- field. +-- +-- Type variables are as follows: +-- +-- * @s@ - the data type containing the value manipulated by these form +-- fields. +-- * @e@ - your application's event type +-- * @n@ - your application's resource name type +data FormFieldState s e n where + FormFieldState :: { formFieldState :: b + -- ^ The current state value associated with + -- the field collection. Note that this type is + -- existential. All form fields in the collection + -- must validate to this type. + , formFieldLens :: Lens' s a + -- ^ A lens to extract and store a + -- successfully-validated form input back into + -- your form state. + , formFieldUpdate :: a -> b -> b + -- ^ Given a new form state value, update the form + -- field state in place. + , formFields :: [FormField a b e n] + -- ^ The form fields, in order, that the user will + -- interact with to manipulate this state value. + , formFieldRenderHelper :: Widget n -> Widget n + -- ^ A helper function to augment the rendered + -- representation of this collection of form + -- fields. It receives the default representation + -- and can augment it, for example, by adding a + -- label on the left. + , 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 +-- underlying state that you choose. This value must be stored in the +-- Brick application's state. +-- +-- Type variables are as follows: +-- +-- * @s@ - the data type of your choosing containing the values +-- manipulated by the fields in this form. +-- * @e@ - your application's event type +-- * @n@ - your application's resource name type +data Form s e n = + Form { formFieldStates :: [FormFieldState s e n] + , formFocus :: FocusRing n + -- ^ The focus ring for the form, indicating which form field + -- has input focus. + , formState :: s + -- ^ The current state of the form. Forms guarantee that only + -- valid inputs ever get stored in the state, and that after + -- each input event on a form field, if that field contains a + -- valid state value then the value is immediately saved to its + -- corresponding field in this state value using the form + -- field's lens over @s@. + , formConcatAll :: [Widget n] -> Widget n + -- ^ Concatenation function for this form's field renderings. + } + +suffixLenses ''Form + +-- | Compose a new rendering augmentation function with the one in the +-- form field collection. For example, we might put a label on the left +-- side of a form field: +-- +-- > (str "Please check: " <+>) @@= checkboxField alive AliveField "Alive?" +-- +-- This can also be used to add multiple augmentations and associates +-- right: +-- +-- > (withDefAttr someAttribute) @@= +-- > (str "Please check: " <+>) @@= +-- > checkboxField alive AliveField "Alive?" +infixr 5 @@= +(@@=) :: (Widget n -> Widget n) -> (s -> FormFieldState s e n) -> s -> FormFieldState s e n +(@@=) h mkFs s = + let v = mkFs s + in v { formFieldRenderHelper = h . (formFieldRenderHelper v) } + +-- | Update the state contained in a form. +-- +-- This updates all form fields to be consistent with the new form +-- state. Where possible, this attempts to maintain other input state, +-- such as text editor cursor position. +-- +-- Note that since this updates the form fields, this means that any +-- field values will be completely overwritten! This may or may not +-- be what you want, since a user actively using the form could get +-- confused if their edits go away. Use carefully. +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 visMode -> + FormFieldState (upd (newState^.l) st) l upd s rh concatAll visMode + in f { formState = newState + , formFieldStates = updateField <$> formFieldStates f + } + +-- | Set the focused field of a form. +setFormFocus :: (Eq n) => n -> Form s e n -> Form s e n +setFormFocus n f = f { formFocus = focusSetCurrent n $ formFocus f } + +-- | Set a form field's concatenation function. +setFieldConcat :: ([Widget n] -> Widget n) -> FormFieldState s e n -> FormFieldState s e n +setFieldConcat f s = s { formFieldConcat = f } + +-- | Set a form's concatenation function. +setFormConcat :: ([Widget n] -> Widget n) -> Form s e n -> Form s e n +setFormConcat func f = f { formConcatAll = func } + +-- | Create a new form with the specified input fields and an initial +-- form state. The fields are initialized from the state using their +-- state lenses and the first form input is focused initially. +newForm :: [s -> FormFieldState s e n] + -- ^ The form field constructors. This is intended to be + -- populated using the various field constructors in this + -- module. + -> s + -- ^ The initial form state used to populate the fields. + -> Form s e n +newForm mkEs s = + let es = mkEs <*> pure s + in Form { formFieldStates = es + , formFocus = focusRing $ concatMap formFieldNames es + , formState = s + , formConcatAll = vBox + } + +formFieldNames :: FormFieldState s e n -> [n] +formFieldNames (FormFieldState _ _ _ fields _ _ _) = formFieldName <$> fields + +-- | A form field for manipulating a boolean value. This represents +-- 'True' as @[X] label@ and 'False' as @[ ] label@. +-- +-- This field responds to `Space` keypresses to toggle the checkbox and +-- to mouse clicks. +checkboxField :: (Ord n, Show n) + => Lens' s Bool + -- ^ The state lens for this value. + -> n + -- ^ The resource name for the input field. + -> T.Text + -- ^ The label for the check box, to appear at its right. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +checkboxField = checkboxCustomField '[' 'X' ']' + +-- | A form field for manipulating a boolean value. This represents +-- 'True' as @[X] label@ and 'False' as @[ ] label@. This function +-- permits the customization of the @[X]@ notation characters. +-- +-- This field responds to `Space` keypresses to toggle the checkbox and +-- to mouse clicks. +checkboxCustomField :: (Ord n, Show n) + => Char + -- ^ Left bracket character. + -> Char + -- ^ Checkmark character. + -> Char + -- ^ Right bracket character. + -> Lens' s Bool + -- ^ The state lens for this value. + -> n + -- ^ The resource name for the input field. + -> T.Text + -- ^ The label for the check box, to appear at its right. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +checkboxCustomField lb check rb stLens name label initialState = + let initVal = initialState ^. stLens + + handleEvent (MouseDown n _ _ _) | n == name = modify not + handleEvent (VtyEvent (EvKey (KChar ' ') [])) = modify not + handleEvent _ = return () + + in FormFieldState { formFieldState = initVal + , formFields = [ FormField name Just True + (renderCheckbox lb check rb label name) + handleEvent + ] + , formFieldLens = stLens + , formFieldUpdate = + \val _ -> val + , formFieldRenderHelper = id + , formFieldConcat = vBox + , formFieldVisibilityMode = ShowFocusedFieldOnly + } + +renderCheckbox :: (Ord n) => Char -> Char -> Char -> T.Text -> n -> Bool -> Bool -> Widget n +renderCheckbox lb check rb label n foc val = + let addAttr = if foc then withDefAttr focusedFormInputAttr else id + csr = if foc then putCursor n (Location (1,0)) else id + in clickable n $ + addAttr $ csr $ + (txt $ T.singleton lb <> (if val then T.singleton check else " ") <> + T.singleton rb <> " ") <+> txt label + +-- | 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) + -- ^ Possible choices. + -> Lens' s (Maybe a) + -- ^ The state lens for the initially/finally selected + -- element. + -> (Bool -> a -> Widget n) + -- ^ List item rendering function. + -> Int + -- ^ List item height in rows. + -> n + -- ^ The resource name for the input field. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +listField options stLens renderItem itemHeight name initialState = + let optionsVector = options initialState + initVal = initialState ^. customStLens + + customStLens :: Lens' s (List n a) + customStLens = lens getList setList + where + getList s = let l = list name optionsVector itemHeight + in case s ^. stLens of + Nothing -> l + Just e -> listMoveToElement e l + setList s l = s & stLens .~ (snd <$> listSelectedElement l) + + handleEvent (VtyEvent e) = handleListEvent e + handleEvent _ = return () + + in FormFieldState { formFieldState = initVal + , formFields = [ FormField name Just True + (renderList renderItem) + handleEvent + ] + , formFieldLens = customStLens + , formFieldUpdate = \listState l -> + case listSelectedElement listState of + Nothing -> l + 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. +-- +-- This field responds to `Space` keypresses to select a radio button +-- option and to mouse clicks. +radioField :: (Ord n, Show n, Eq a) + => Lens' s a + -- ^ The state lens for this value. + -> [(a, n, T.Text)] + -- ^ The available choices, in order. Each choice has a value + -- of type @a@, a resource name, and a text label. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +radioField = radioCustomField '[' '*' ']' + +-- | A form field for selecting a single choice from a set of possible +-- choices. Each choice has an associated value and text label. This +-- function permits the customization of the @[*]@ notation characters. +-- +-- This field responds to `Space` keypresses to select a radio button +-- option and to mouse clicks. +radioCustomField :: (Ord n, Show n, Eq a) + => Char + -- ^ Left bracket character. + -> Char + -- ^ Checkmark character. + -> Char + -- ^ Right bracket character. + -> Lens' s a + -- ^ The state lens for this value. + -> [(a, n, T.Text)] + -- ^ The available choices, in order. Each choice has a value + -- of type @a@, a resource name, and a text label. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +radioCustomField lb check rb stLens options initialState = + let initVal = initialState ^. stLens + + lookupOptionValue n = + let results = filter (\(_, n', _) -> n' == n) options + in case results of + [(val, _, _)] -> Just val + _ -> Nothing + + handleEvent _ (MouseDown n _ _ _) = + case lookupOptionValue n of + Nothing -> return () + Just v -> put v + handleEvent new (VtyEvent (EvKey (KChar ' ') [])) = put new + handleEvent _ _ = return () + + optionFields = mkOptionField <$> options + mkOptionField (val, name, label) = + FormField name + Just + True + (renderRadio lb check rb val name label) + (handleEvent val) + + in FormFieldState { formFieldState = initVal + , formFields = optionFields + , formFieldLens = stLens + , 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 +renderRadio lb check rb val name label foc cur = + let addAttr = if foc + then withDefAttr focusedFormInputAttr + else id + isSet = val == cur + csr = if foc then putCursor name (Location (1,0)) else id + in clickable name $ + addAttr $ csr $ + txt $ T.concat + [ T.singleton lb + , if isSet then T.singleton check else " " + , T.singleton rb <> " " <> label + ] + +-- | A form field for using an editor to edit the text representation of +-- a value. The other editing fields in this module are special cases of +-- 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) + => Lens' s a + -- ^ The state lens for this value. + -> n + -- ^ The resource name for the input field. + -> Maybe Int + -- ^ The optional line limit for the editor (see 'editor'). + -> (a -> T.Text) + -- ^ The initialization function that turns your value into + -- the editor's initial contents. The resulting text may + -- contain newlines. + -> ([T.Text] -> Maybe a) + -- ^ The validation function that converts the editor's + -- contents into a valid value of type @a@. + -> ([T.Text] -> Widget n) + -- ^ The rendering function for the editor's contents (see + -- 'renderEditor'). + -> (Widget n -> Widget n) + -- ^ A rendering augmentation function to adjust the + -- representation of the rendered editor. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +editField stLens n limit ini val renderText wrapEditor initialState = + let initVal = applyEdit gotoEnd $ + editor n limit initialText + gotoEnd = let ls = T.lines initialText + pos = (length ls - 1, T.length (last ls)) + in if null ls + then id + else Z.moveCursor pos + initialText = ini $ initialState ^. stLens + + in FormFieldState { formFieldState = initVal + , formFields = [ FormField n + (val . getEditContents) + True + (\b e -> wrapEditor $ renderEditor renderText b e) + handleEditorEvent + ] + , formFieldLens = stLens + , formFieldUpdate = \newVal e -> + let newTxt = ini newVal + in if newTxt == (T.unlines $ getEditContents e) + then e + 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' +-- representation of a state field value of type @a@. This automatically +-- uses its 'Read' instance to validate the input. This field is mostly +-- 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) + => Lens' s a + -- ^ The state lens for this value. + -> n + -- ^ The resource name for the input field. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +editShowableField stLens n = + editShowableFieldWithValidate stLens n (const True) + +-- | A form field using a single-line editor to edit the 'Show' representation +-- of a state field value of type @a@. This automatically uses its 'Read' +-- instance to validate the input, and also accepts an additional user-defined +-- pass for validation. This field is mostly useful in cases where the +-- 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) + => Lens' s a + -- ^ The state lens for this value. + -> n + -- ^ The resource name for the input field. + -> (a -> Bool) + -- ^ Additional validation step for input. + -- 'True' indicates that the value is + -- valid. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +editShowableFieldWithValidate stLens n isValid = + let ini = T.pack . show + val ls = do + v <- readMaybe $ T.unpack $ T.intercalate "\n" ls + if isValid v + then return v + else Nothing + limit = Just 1 + renderText = txt . T.unlines + in editField stLens n limit ini val renderText id + +-- | 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) + => Lens' s T.Text + -- ^ The state lens for this value. + -> n + -- ^ The resource name for the input field. + -> Maybe Int + -- ^ The optional line limit for the editor (see 'editor'). + -> s + -- ^ The initial form state. + -> FormFieldState s e n +editTextField stLens n limit = + let ini = id + val = Just . T.intercalate "\n" + renderText = txt . T.intercalate "\n" + in editField stLens n limit ini val renderText id + +-- | A form field using a single-line editor to edit a free-form text +-- 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) + => Lens' s T.Text + -- ^ The state lens for this value. + -> n + -- ^ The resource name for the input field. + -> s + -- ^ The initial form state. + -> FormFieldState s e n +editPasswordField stLens n = + let ini = id + val = Just . T.concat + limit = Just 1 + renderText = toPassword + in editField stLens n limit ini val renderText id + +toPassword :: [T.Text] -> Widget a +toPassword s = txt $ T.replicate (T.length $ T.concat s) "*" + +-- | The namespace for the other form attributes. +formAttr :: AttrName +formAttr = attrName "brickForm" + +-- | 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. 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" + +-- | Returns whether all form fields in the form currently have valid +-- values according to the fields' validation functions. This is useful +-- when we need to decide whether the form state is up to date with +-- respect to the form input fields. +allFieldsValid :: Form s e n -> Bool +allFieldsValid = null . invalidFields + +-- | Returns the resource names associated with all form input fields +-- that currently have invalid inputs. This is useful when we need to +-- force the user to repair invalid inputs before moving on from a form +-- editing session. +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 +-- needs to be fed back into the form state. +setFieldValid :: (Eq n) + => Bool + -- ^ Whether the field is considered valid. + -> n + -- ^ The name of the form field to set as (in)valid. + -> Form s e n + -- ^ The form to modify. + -> Form s e n +setFieldValid v n form = + let go1 [] = [] + go1 (s:ss) = + let s' = case s of + 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 visMode + in s' : go1 ss + + in form { formFieldStates = go1 (formFieldStates form) } + +getInvalidFields :: FormFieldState s e n -> [n] +getInvalidFields (FormFieldState st _ _ fs _ _ _) = + let gather (FormField n validate extValid _ _) = + if not extValid || isNothing (validate st) then [n] else [] + in concatMap gather fs + +-- | Render a form. +-- +-- For each form field, each input for the field is rendered using +-- the implementation provided by its 'FormField'. The inputs are +-- then concatenated with the field's concatenation function (see +-- 'setFieldConcat') and are then augmented using the form field's +-- rendering augmentation function (see '@@='). Fields with invalid +-- inputs (either due to built-in validator failure or due to external +-- validation failure via 'setFieldValid') will be displayed using the +-- 'invalidFormInputAttr' attribute. +-- +-- Finally, all of the resulting field renderings are concatenated with +-- 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 + +-- | Render a single form field collection. This is called internally by +-- 'renderForm' but is exposed in cases where a form field state needs +-- to be rendered outside of a 'Form', so 'renderForm' is probably what +-- you want. +renderFormFieldState :: (Eq n) + => FocusRing n + -> FormFieldState s e n + -> Widget n +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 + 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: +-- +-- * On @Tab@ keypresses, this changes the focus to the next field in +-- the form. +-- * On @Shift-Tab@ keypresses, this changes the focus to the previous +-- field in the form. +-- * On mouse button presses (regardless of button or modifier), the +-- focus is changed to the clicked form field and the event is +-- forwarded to the event handler for the clicked form field. +-- * On @Left@ or @Up@, if the currently-focused field is part of a +-- collection (e.g. radio buttons), the previous entry in the +-- collection is focused. +-- * On @Right@ or @Down@, if the currently-focused field is part of a +-- collection (e.g. radio buttons), the next entry in the collection +-- is focused. +-- * All other events are forwarded to the currently focused form field. +-- +-- In all cases where an event is forwarded to a form field, validation +-- of the field's input state is performed immediately after the +-- event has been handled. If the form field's input state succeeds +-- validation using the field's validator function, its value is +-- immediately stored in the form state using the form field's state +-- lens. The external validation flag is ignored during this step to +-- ensure that external validators have a chance to get the intermediate +-- validated value. +handleFormEvent :: (Eq n) => BrickEvent n e -> EventM n (Form s e n) () +handleFormEvent (VtyEvent (EvKey (KChar '\t') [])) = + formFocusL %= focusNext +handleFormEvent (VtyEvent (EvKey KBackTab [])) = + formFocusL %= focusPrev +handleFormEvent e@(MouseDown n _ _ _) = do + formFocusL %= focusSetCurrent n + handleFormFieldEvent e n +handleFormEvent e@(MouseUp n _ _) = do + formFocusL %= focusSetCurrent n + handleFormFieldEvent e n +handleFormEvent e@(VtyEvent (EvKey KUp [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryBefore grp n) +handleFormEvent e@(VtyEvent (EvKey KDown [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryAfter grp n) +handleFormEvent e@(VtyEvent (EvKey KLeft [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryBefore grp n) +handleFormEvent e@(VtyEvent (EvKey KRight [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryAfter grp n) +handleFormEvent e = + forwardToCurrent e + +getFocusGrouping :: (Eq n) => Form s e n -> n -> Maybe [n] +getFocusGrouping f n = findGroup (formFieldStates f) + where + findGroup [] = Nothing + findGroup (e:es) = + let ns = formFieldNames e + in if n `elem` ns && length ns > 1 + then Just ns + else findGroup es + +entryAfter :: (Eq a) => [a] -> a -> a +entryAfter as a = + let i = fromJust $ elemIndex a as + i' = if i == length as - 1 then 0 else i + 1 + in as !! i' + +entryBefore :: (Eq a) => [a] -> a -> a +entryBefore as a = + let i = fromJust $ elemIndex a as + 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 e act = do + foc <- gets formFocus + case focusGetCurrent foc of + Nothing -> return () + Just n -> do + f <- get + case getFocusGrouping f n of + Nothing -> forwardToCurrent e + Just grp -> act n grp + +withFocus :: (n -> EventM n (Form s e n) ()) -> EventM n (Form s e n) () +withFocus act = do + foc <- gets formFocus + case focusGetCurrent foc of + Nothing -> return () + Just n -> act n + +forwardToCurrent :: (Eq n) => BrickEvent n e -> EventM n (Form s e n) () +forwardToCurrent = + withFocus . handleFormFieldEvent + +handleFormFieldEvent :: (Eq n) => BrickEvent n e -> n -> EventM n (Form s e n) () +handleFormFieldEvent ev n = do + let findFieldState _ [] = return () + findFieldState prev (e:es) = + case e of + FormFieldState st stLens upd fields helper concatAll visMode -> do + let findField [] = return Nothing + findField (field:rest) = + case field of + FormField n' validate _ _ handleFunc | n == n' -> do + (nextSt, ()) <- nestEventM st (handleFunc ev) + -- If the new state validates, go ahead and update + -- the form state with it. + case validate nextSt of + Nothing -> return $ Just (nextSt, Nothing) + Just newSt -> return $ Just (nextSt, Just newSt) + _ -> findField rest + + result <- findField fields + case result of + Nothing -> findFieldState (prev <> [e]) es + Just (newSt, maybeSt) -> do + let newFieldState = FormFieldState newSt stLens upd fields helper concatAll visMode + formFieldStatesL .= prev <> [newFieldState] <> es + case maybeSt of + Nothing -> return () + Just s -> formStateL.stLens .= s + + states <- gets formFieldStates + findFieldState [] states diff --git a/src/Brick/Keybindings.hs b/src/Brick/Keybindings.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings.hs @@ -0,0 +1,20 @@ +-- | The re-exporting catch-all module for the customizable keybindings +-- API. +-- +-- To get started using this API, see the documentation in +-- @KeyDispatcher@ as well as the User Guide section on customizable +-- keybindings. +module Brick.Keybindings + ( module Brick.Keybindings.KeyEvents + , module Brick.Keybindings.KeyConfig + , module Brick.Keybindings.KeyDispatcher + , module Brick.Keybindings.Pretty + , module Brick.Keybindings.Parse + ) +where + +import Brick.Keybindings.KeyEvents +import Brick.Keybindings.KeyConfig +import Brick.Keybindings.KeyDispatcher +import Brick.Keybindings.Pretty +import Brick.Keybindings.Parse diff --git a/src/Brick/Keybindings/KeyConfig.hs b/src/Brick/Keybindings/KeyConfig.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/KeyConfig.hs @@ -0,0 +1,258 @@ +-- | This module provides 'KeyConfig' and associated functions. A +-- 'KeyConfig' is the basis for the custom keybinding system in this +-- library. +-- +-- To get started, see 'newKeyConfig'. Once a 'KeyConfig' has been +-- constructed, see 'Brick.Keybindings.KeyHandlerMap.keyDispatcher'. +-- +-- Since a key configuration can have keys bound to multiple events, it +-- is the application author's responsibility to check for collisions +-- since the nature of the collisions will depend on how the application +-- is implemented. To check for collisions, use the result of +-- 'keyEventMappings'. +module Brick.Keybindings.KeyConfig + ( KeyConfig + , newKeyConfig + , BindingState(..) + + -- * Specifying bindings + , Binding(..) + , ToBinding(..) + , binding + , fn + , meta + , ctrl + , shift + + -- * Querying KeyConfigs + , firstDefaultBinding + , firstActiveBinding + , allDefaultBindings + , allActiveBindings + , keyEventMappings + + -- * Misc + , keyConfigEvents + , lookupKeyConfigBindings + ) +where + +import Data.List (nub) +import qualified Data.Map.Strict as M +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Data.Set as S +import Data.Maybe (fromMaybe, listToMaybe, catMaybes) +import qualified Graphics.Vty as Vty + +import Brick.Keybindings.KeyEvents +import Brick.Keybindings.Normalize + +-- | A key binding. +-- +-- The easiest way to express 'Binding's is to use the helper functions +-- in this module that work with instances of 'ToBinding', e.g. +-- +-- @ +-- let ctrlB = 'ctrl' \'b\' +-- shiftX = 'shift' \'x\' +-- ctrlMetaK = 'ctrl' $ 'meta' \'k\' +-- -- Or with Vty keys directly: +-- ctrlDown = 'ctrl' 'Graphics.Vty.Input.KDown' +-- @ +data Binding = + Binding { kbKey :: Vty.Key + -- ^ The key itself. + , kbMods :: S.Set Vty.Modifier + -- ^ The set of modifiers. + } deriving (Eq, Show, Ord) + +-- | Construct a 'Binding'. Modifier order is ignored. 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 = normalizeKey mods k + , kbMods = S.fromList mods + } + +-- | An explicit configuration of key bindings for a key event. +data BindingState = + BindingList [Binding] + -- ^ Bind the event to the specified list of bindings. + | Unbound + -- ^ Disable all bindings for the event, including default bindings. + deriving (Show, Eq, Ord) + +-- | A configuration of custom key bindings. A 'KeyConfig' +-- stores everything needed to resolve a key event into one or +-- more key bindings. Make a 'KeyConfig' with 'newKeyConfig', +-- then use it to dispatch to 'KeyEventHandler's with +-- 'Brick.Keybindings.KeyHandlerMap.keyDispatcher'. +-- +-- Make a new 'KeyConfig' with 'newKeyConfig'. +-- +-- A 'KeyConfig' stores: +-- +-- * A collection of named key events, mapping the event type @k@ to +-- 'Text' labels. +-- * For each event @k@, optionally store a list of default key bindings +-- for that event. +-- * An optional customized binding list for each event, setting the +-- event to either 'Unbound' or providing explicit overridden bindings +-- with 'BindingList'. +data KeyConfig k = + KeyConfig { keyConfigCustomBindings :: [(k, BindingState)] + -- ^ The list of custom binding states for events with + -- custom bindings. We use a list to ensure that we + -- preserve key bindings for keys that are mapped to more + -- than one event. This may be valid or invalid depending + -- on the events in question; whether those bindings + -- constitute a collision is up to the application + -- developer to check. + , keyConfigEvents :: KeyEvents k + -- ^ The base mapping of events and their names that is + -- used in this configuration. + , keyConfigDefaultBindings :: M.Map k [Binding] + -- ^ A mapping of events and their default key bindings, + -- if any. + } + deriving (Show, Eq) + +-- | Build a 'KeyConfig' with the specified 'KeyEvents' event-to-name +-- mapping, list of default bindings by event, and list of custom +-- bindings by event. +newKeyConfig :: (Ord k) + => KeyEvents k + -- ^ The base mapping of key events and names to use. + -> [(k, [Binding])] + -- ^ Default bindings by key event, such as from a + -- configuration file or embedded code. Optional on a + -- per-event basis. + -> [(k, BindingState)] + -- ^ Custom bindings by key event, such as from a + -- configuration file. Explicitly setting an event to + -- 'Unbound' here has the effect of disabling its default + -- bindings. Optional on a per-event basis. Note that this + -- function does not check for collisions since it is up to + -- the application to determine whether a key bound to more + -- than one event constitutes a collision! + -> KeyConfig k +newKeyConfig evs defaults bindings = + KeyConfig { keyConfigCustomBindings = bindings + , keyConfigEvents = evs + , keyConfigDefaultBindings = M.fromList defaults + } + +-- | Return a list of mappings including each key bound to any event +-- combined with the list of events to which it is bound. This is useful +-- for identifying problematic key binding collisions. Since key binding +-- collisions cannot be determined in general, we leave it up to the +-- application author to determine which key-to-event bindings are +-- problematic. +keyEventMappings :: (Ord k, Eq k) => KeyConfig k -> [(Binding, S.Set k)] +keyEventMappings kc = M.toList resultMap + where + -- Get all default bindings + defaultBindings = M.toList $ keyConfigDefaultBindings kc + -- Get all explicitly unbound events + explicitlyUnboundEvents = fmap fst $ filter ((== Unbound) . snd) $ keyConfigCustomBindings kc + -- Remove explicitly unbound events from the default set of + -- bindings + defaultBindingsWithoutUnbound = filter ((`notElem` explicitlyUnboundEvents) . fst) defaultBindings + -- Now get customized binding lists + customizedKeybindingLists = catMaybes $ (flip fmap) (keyConfigCustomBindings kc) $ \(k, bState) -> do + case bState of + Unbound -> Nothing + BindingList bs -> Just (k, bs) + -- Now build a map from binding to event list + allPairs = defaultBindingsWithoutUnbound <> + customizedKeybindingLists + addBindings m (ev, bs) = + M.unionWith S.union m $ M.fromList [(b, S.singleton ev) | b <- bs] + resultMap = foldl addBindings mempty allPairs + +-- | Look up the binding state for the specified event. This returns +-- 'Nothing' when the event has no explicitly configured custom +-- 'BindingState'. +lookupKeyConfigBindings :: (Ord k) => KeyConfig k -> k -> Maybe BindingState +lookupKeyConfigBindings kc e = lookup e $ keyConfigCustomBindings kc + +-- | A convenience function to return the first result of +-- 'allDefaultBindings', if any. +firstDefaultBinding :: (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding +firstDefaultBinding kc ev = do + bs <- M.lookup ev (keyConfigDefaultBindings kc) + case bs of + (b:_) -> Just b + _ -> Nothing + +-- | Returns the list of default bindings for the specified event, +-- irrespective of whether the event has been explicitly configured with +-- other bindings or set to 'Unbound'. +allDefaultBindings :: (Ord k) => KeyConfig k -> k -> [Binding] +allDefaultBindings kc ev = + fromMaybe [] $ M.lookup ev (keyConfigDefaultBindings kc) + +-- | A convenience function to return the first result of +-- 'allActiveBindings', if any. +firstActiveBinding :: (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding +firstActiveBinding kc ev = listToMaybe $ allActiveBindings kc ev + +-- | Return all active key bindings for the specified event. This +-- returns customized bindings if any have been set in the 'KeyConfig', +-- no bindings if the event has been explicitly set to 'Unbound', or the +-- default bindings if the event is absent from the customized bindings. +allActiveBindings :: (Show k, Ord k) => KeyConfig k -> k -> [Binding] +allActiveBindings kc ev = nub foundBindings + where + defaultBindings = allDefaultBindings kc ev + foundBindings = case lookupKeyConfigBindings kc ev of + Just (BindingList bs) -> bs + Just Unbound -> [] + Nothing -> defaultBindings + +-- | The class of types that can form the basis of 'Binding's. +-- +-- This is provided to make it easy to write and modify bindings in less +-- verbose ways. +class ToBinding a where + -- | Binding constructor. + bind :: a -> Binding + +instance ToBinding Vty.Key where + bind k = Binding { kbMods = mempty, kbKey = k } + +instance ToBinding Char where + bind = bind . Vty.KChar + +instance ToBinding Binding where + bind = id + +addModifier :: (ToBinding a) => Vty.Modifier -> a -> Binding +addModifier m val = + let b = bind val + newMods = S.insert m $ kbMods b + in b { kbMods = newMods + , kbKey = normalizeKey (S.toList newMods) $ kbKey b + } + +-- | 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. 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. If the binding is for a character key, force +-- it to lowercase. +shift :: (ToBinding a) => a -> Binding +shift = addModifier Vty.MShift + +-- | Function key binding. +fn :: Int -> Binding +fn = bind . Vty.KFun diff --git a/src/Brick/Keybindings/KeyDispatcher.hs b/src/Brick/Keybindings/KeyDispatcher.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/KeyDispatcher.hs @@ -0,0 +1,241 @@ +-- | This is the entry point into the keybinding infrastructure in +-- this library. Note that usage of this API is not required to create +-- working Brick applications; this API is provided for applications +-- that need to support custom keybindings that are less tightly coupled +-- to application behavior. +-- +-- The workflow for this API is as follows: +-- +-- * Create a data type @k@ with a constructor for each abstract +-- application event that you want to trigger with an input key. +-- * To each event @k@, assign a unique user-readable name (such as a +-- name you could imagine using in a configuration file to refer to +-- the event) and a list of default key bindings. +-- * Use the resulting data to create a 'KeyConfig' with 'newKeyConfig'. +-- If desired, provide custom keybindings to 'newKeyConfig' from +-- within the program or load them from an INI file with routines like +-- 'Brick.Keybindings.Parse.keybindingsFromFile'. +-- * Optionally check for configuration-wide keybinding collisions with +-- 'Brick.Keybindings.KeyConfig.keyEventMappings'. +-- * Implement application event handlers that will be run in response +-- to either specific hard-coded keys or events @k@, both in some +-- monad @m@ of your choosing, using constructors 'onKey' and +-- 'onEvent'. +-- * Use the created 'KeyConfig' and handlers to create a +-- 'KeyDispatcher' with 'keyDispatcher', dealing with collisions if +-- they arise. +-- * As user input events arrive, dispatch them to the appropriate +-- handler in the dispatcher using 'handleKey'. +module Brick.Keybindings.KeyDispatcher + ( -- * Key dispatching + KeyDispatcher + , keyDispatcher + , handleKey + + -- * Building handlers + , onEvent + , onKey + + -- * Handlers and triggers + , Handler(..) + , KeyHandler(..) + , KeyEventHandler(..) + , EventTrigger(..) + + -- * Misc + , keyDispatcherToList + , lookupVtyEvent + ) +where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Graphics.Vty as Vty +import Data.Function (on) +import Data.List (groupBy, sortBy) + +import Brick.Keybindings.KeyConfig + +-- | A dispatcher keys that map to abstract events @k@ and whose +-- handlers run in the monad @m@. +newtype KeyDispatcher k m = KeyDispatcher (M.Map Binding (KeyHandler k m)) + +-- | A 'Handler' represents a handler implementation to be invoked in +-- response to some event that runs in the monad @m@. +-- +-- In general, you should never need to make one of these manually. +-- Instead, use 'onEvent' and 'onKey'. This type's internals are exposed +-- for easy inspection, not construction. +data Handler m = + Handler { handlerDescription :: T.Text + -- ^ The description of this handler's behavior. + , handlerAction :: m () + -- ^ The action to take when this handler is invoked. + } + +-- | A handler for a specific key. +-- +-- In general, you should never need to create one of these manually. +-- The internals are exposed to make inspection easy. +data KeyHandler k m = + KeyHandler { khHandler :: KeyEventHandler k m + -- ^ The handler to invoke. Note that this maintains + -- the original abstract key event handler; this allows + -- us to obtain the original 'EventTrigger' for the + -- 'KeyEventHandler' upon which this 'KeyHandler' + -- is built. This can be important for keybinding + -- consistency checks or collision checks as well as help + -- text generation. + , khBinding :: Binding + -- ^ The specific key binding that should trigger this + -- handler. + } + +-- | Find the key handler that matches a Vty key event, if any. Modifier +-- order is unimportant since the lookup for a matching binding ignores +-- modifier order. +-- +-- This works by looking up an event handler whose binding is the +-- specified key and modifiers based on the 'KeyConfig' that was used to +-- build the 'KeyDispatcher'. +-- +-- Ordinarily you will not need to use this function; use 'handleKey' +-- instead. This is provided for more direct access to the +-- 'KeyDispatcher' internals. +lookupVtyEvent :: Vty.Key -> [Vty.Modifier] -> KeyDispatcher k m -> Maybe (KeyHandler k m) +lookupVtyEvent k mods (KeyDispatcher m) = M.lookup (Binding k $ S.fromList mods) m + +-- | Handle a keyboard event by looking it up in the 'KeyDispatcher' +-- and invoking the matching binding's handler if one is found. Return +-- @True@ if the a matching handler was found and run; return @False@ if +-- no matching binding was found. +handleKey :: (Monad m) + => KeyDispatcher k m + -- ^ The dispatcher to use. + -> Vty.Key + -- ^ The key to handle. + -> [Vty.Modifier] + -- ^ The modifiers for the key, if any. + -> m Bool +handleKey d k mods = do + case lookupVtyEvent k mods d of + Just kh -> (handlerAction $ kehHandler $ khHandler kh) >> return True + Nothing -> return False + +-- | Build a 'KeyDispatcher' to dispatch keys to handle events of type +-- @k@ using actions in a Monad @m@. If any collisions are detected, +-- this fails with 'Left' and returns the list of colliding event +-- handlers for each overloaded binding. (Each returned 'KeyHandler' +-- contains the original 'KeyEventHandler' that was used to build it so +-- those can be inspected to understand which handlers are mapped to the +-- same key, either via an abstract key event using 'onEvent' or via a +-- statically configured key using 'onKey'.) +-- +-- This works by taking a list of abstract 'KeyEventHandler's and +-- building a 'KeyDispatcher' of event handlers based on specific Vty +-- keys using the provided 'KeyConfig' to map between abstract key +-- events of type @k@ and Vty keys. Event handlers triggered by an event +-- @k@ are set up to be triggered by either the customized bindings for +-- @k@ in the 'KeyConfig', no bindings at all if the 'KeyConfig' has +-- marked @k@ as 'Unbound', or the default bindings for @k@ otherwise. +-- +-- Once you have a 'KeyDispatcher', you can dispatch an input key event +-- to it and invoke the corresponding handler (if any) with 'handleKey'. +keyDispatcher :: (Ord k) + => KeyConfig k + -> [KeyEventHandler k m] + -> Either [(Binding, [KeyHandler k m])] (KeyDispatcher k m) +keyDispatcher conf ks = + let pairs = buildKeyDispatcherPairs ks conf + 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) + in if null badGroups + then Right $ KeyDispatcher $ M.fromList pairs + else Left $ combine <$> badGroups + +-- | Convert a key dispatcher to a list of pairs of bindings and their +-- handlers. +keyDispatcherToList :: KeyDispatcher k m + -> [(Binding, KeyHandler k m)] +keyDispatcherToList (KeyDispatcher m) = M.toList m + +buildKeyDispatcherPairs :: (Ord k) + => [KeyEventHandler k m] + -> KeyConfig k + -> [(Binding, KeyHandler k m)] +buildKeyDispatcherPairs ks conf = pairs + where + pairs = mkPair <$> handlers + mkPair h = (khBinding h, h) + handlers = concatMap (keyHandlersFromConfig conf) ks + +keyHandlersFromConfig :: (Ord k) + => KeyConfig k + -> KeyEventHandler k m + -> [KeyHandler k m] +keyHandlersFromConfig kc eh = + let allBindingsFor ev | Just (BindingList ks) <- lookupKeyConfigBindings kc ev = ks + | Just Unbound <- lookupKeyConfigBindings kc ev = [] + | otherwise = allDefaultBindings kc ev + bindings = case kehEventTrigger eh of + ByKey b -> [b] + ByEvent ev -> allBindingsFor ev + in [ KeyHandler { khHandler = eh, khBinding = b } | b <- bindings ] + +mkHandler :: T.Text -> m () -> Handler m +mkHandler msg action = + Handler { handlerDescription = msg + , handlerAction = action + } + +-- | Specify a handler for the specified key event. +onEvent :: k + -- ^ The key event whose bindings should trigger this handler. + -> T.Text + -- ^ The description of the handler. + -> m () + -- ^ The handler to invoke. + -> KeyEventHandler k m +onEvent ev msg action = + KeyEventHandler { kehHandler = mkHandler msg action + , kehEventTrigger = ByEvent ev + } + +-- | Specify a handler for the specified key. +onKey :: (ToBinding a) + => a + -- ^ The binding that should trigger this handler. + -> T.Text + -- ^ The description of the handler. + -> m () + -- ^ The handler to invoke. + -> KeyEventHandler k m +onKey b msg action = + KeyEventHandler { kehHandler = mkHandler msg action + , kehEventTrigger = ByKey $ bind b + } + +-- | A trigger for an event handler. +data EventTrigger k = + ByKey Binding + -- ^ The key event is always triggered by a specific key. + | ByEvent k + -- ^ The trigger is an abstract key event. + deriving (Show, Eq, Ord) + +-- | A handler for an abstract key event. +-- +-- In general, you should never need to create these manually. Instead, +-- use 'onEvent' and 'onKey'. The internals of this type are exposed to +-- allow inspection of handler data for e.g. custom help generation. +data KeyEventHandler k m = + KeyEventHandler { kehHandler :: Handler m + -- ^ The handler to invoke. + , kehEventTrigger :: EventTrigger k + -- ^ The trigger for the handler. + } diff --git a/src/Brick/Keybindings/KeyEvents.hs b/src/Brick/Keybindings/KeyEvents.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/KeyEvents.hs @@ -0,0 +1,52 @@ +-- | This module provides 'KeyEvents', a data type for mapping +-- application-defined abstract events to user-facing names (e.g. +-- for use in configuration files and documentation). This data +-- structure gives you a place to define the correspondence between +-- your application's key events and their names. A 'KeyEvents' also +-- effectively tells the key binding system about the collection of +-- possible abstract events that can be handled. +-- +-- A 'KeyEvents' is used to construct a +-- 'Brick.Keybindings.KeyConfig.KeyConfig' with +-- 'Brick.Keybindings.KeyConfig.newKeyConfig'. +module Brick.Keybindings.KeyEvents + ( KeyEvents + , keyEvents + , keyEventsList + , lookupKeyEvent + , keyEventName + ) +where + +import qualified Data.Bimap as B +import qualified Data.Text as T + +-- | A bidirectional mapping between events @k@ and their user-readable +-- names. +data KeyEvents k = KeyEvents (B.Bimap T.Text k) + deriving (Eq, Show) + +-- | Build a new 'KeyEvents' map from the specified list of events and +-- names. Key event names are stored in lowercase. +-- +-- Calls 'error' if any events have the same name (ignoring case) or if +-- multiple names map to the same event. +keyEvents :: (Ord k) => [(T.Text, k)] -> KeyEvents k +keyEvents pairs = + let m = B.fromList [(T.strip $ T.toLower n, e) | (n, e) <- pairs] + in if B.size m /= length pairs + then error "keyEvents: input list contains duplicates by name or by event value" + else KeyEvents $ B.fromList pairs + +-- | Convert the 'KeyEvents' to a list. +keyEventsList :: KeyEvents k -> [(T.Text, k)] +keyEventsList (KeyEvents m) = B.toList m + +-- | Look up the specified event name to get its abstract event. The +-- lookup ignores leading and trailing whitespace as well as case. +lookupKeyEvent :: (Ord k) => KeyEvents k -> T.Text -> Maybe k +lookupKeyEvent (KeyEvents m) name = B.lookup (T.strip $ T.toLower name) m + +-- | Given an abstract event, get its event name. +keyEventName :: (Ord k) => KeyEvents k -> k -> Maybe T.Text +keyEventName (KeyEvents m) e = B.lookupR e m diff --git a/src/Brick/Keybindings/Normalize.hs b/src/Brick/Keybindings/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/Normalize.hs @@ -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 diff --git a/src/Brick/Keybindings/Parse.hs b/src/Brick/Keybindings/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/Parse.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides key binding string parsing functions for use +-- in e.g. reading key bindings from configuration files. +module Brick.Keybindings.Parse + ( parseBinding + , parseBindingList + , normalizeKey + + , keybindingsFromIni + , keybindingsFromFile + , keybindingIniParser + ) +where + +import Control.Monad (forM) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Graphics.Vty as Vty +import Text.Read (readMaybe) +import qualified Data.Ini.Config as Ini + +import Brick.Keybindings.KeyEvents +import Brick.Keybindings.KeyConfig +import Brick.Keybindings.Normalize + +-- | Parse a key binding list into a 'BindingState'. +-- +-- A key binding list either the string @"unbound"@ or is a +-- comma-separated list of 'Binding's parsed with 'parseBinding'. +parseBindingList :: T.Text -> Either String BindingState +parseBindingList t = + if T.toLower t == "unbound" + then return Unbound + else BindingList <$> mapM (parseBinding . T.strip) (T.splitOn "," $ T.strip t) + +-- | Parse a key binding string. Key binding strings specify zero or +-- more modifier keys and a base key, separated by hyphens. +-- +-- @ +-- (modifier "-")* key +-- @ +-- +-- e.g. @c-down@, @backspace@, @ctrl-shift-f1@. +-- +-- where each @modifier@ is parsed case-insensitively as follows: +-- +-- * @"s", "shift"@: 'Vty.MShift' +-- * @"m", "meta"@: 'Vty.MMeta' +-- * @"a", "alt"@: 'Vty.MAlt' +-- * @"c", "ctrl", "control"@: 'Vty.MCtrl' +-- +-- and @key@ is parsed case-insensitively as follows: +-- +-- * "f1", "f2", ...: 'Vty.KFun' +-- * "esc": 'Vty.KEsc' +-- * "backspace": 'Vty.KBS' +-- * "enter": 'Vty.KEnter' +-- * "left": 'Vty.KLeft' +-- * "right": 'Vty.KRight' +-- * "up": 'Vty.KUp' +-- * "down": 'Vty.KDown' +-- * "upleft": 'Vty.KUpLeft' +-- * "upright": 'Vty.KUpRight' +-- * "downleft": 'Vty.KDownLeft' +-- * "downright": 'Vty.KDownRight' +-- * "center": 'Vty.KCenter' +-- * "backtab": 'Vty.KBackTab' +-- * "printscreen": 'Vty.KPrtScr' +-- * "pause": 'Vty.KPause' +-- * "insert": 'Vty.KIns' +-- * "home": 'Vty.KHome' +-- * "pgup": 'Vty.KPageUp' +-- * "del": 'Vty.KDel' +-- * "end": 'Vty.KEnd' +-- * "pgdown": 'Vty.KPageDown' +-- * "begin": 'Vty.KBegin' +-- * "menu": 'Vty.KMenu' +-- * "space": @' '@ +-- * "tab": @'\\t'@ +-- * Otherwise, 'Vty.KChar' +parseBinding :: T.Text -> Either String Binding +parseBinding s = go (T.splitOn "-" $ T.toLower s) [] + where go [k] mods = do + k' <- pKey k + return $ binding k' mods + go (k:ks) mods = do + m <- case k of + "s" -> return Vty.MShift + "shift" -> return Vty.MShift + "m" -> return Vty.MMeta + "meta" -> return Vty.MMeta + "a" -> return Vty.MAlt + "alt" -> return Vty.MAlt + "c" -> return Vty.MCtrl + "ctrl" -> return Vty.MCtrl + "control" -> return Vty.MCtrl + _ -> Left ("Unknown modifier prefix: " ++ show k) + go ks (m:mods) + go [] _ = Left "Empty keybinding not allowed" + pKey "esc" = return Vty.KEsc + pKey "backspace" = return Vty.KBS + pKey "enter" = return Vty.KEnter + pKey "left" = return Vty.KLeft + pKey "right" = return Vty.KRight + pKey "up" = return Vty.KUp + pKey "down" = return Vty.KDown + pKey "upleft" = return Vty.KUpLeft + pKey "upright" = return Vty.KUpRight + pKey "downleft" = return Vty.KDownLeft + pKey "downright" = return Vty.KDownRight + pKey "center" = return Vty.KCenter + pKey "backtab" = return Vty.KBackTab + pKey "printscreen" = return Vty.KPrtScr + pKey "pause" = return Vty.KPause + pKey "insert" = return Vty.KIns + pKey "home" = return Vty.KHome + pKey "pgup" = return Vty.KPageUp + pKey "del" = return Vty.KDel + pKey "end" = return Vty.KEnd + pKey "pgdown" = return Vty.KPageDown + pKey "begin" = return Vty.KBegin + pKey "menu" = return Vty.KMenu + pKey "space" = return (Vty.KChar ' ') + pKey "tab" = return (Vty.KChar '\t') + pKey t + | T.length t == 1 = + return (Vty.KChar $ T.last s) + | Just n <- T.stripPrefix "f" t = + case readMaybe (T.unpack n) of + Nothing -> Left ("Unknown keybinding: " ++ show t) + Just i -> return (Vty.KFun i) + | otherwise = Left ("Unknown keybinding: " ++ show t) + +-- | Parse custom key bindings from the specified INI file using the +-- provided event name mapping. +-- +-- Each line in the specified section can take the form +-- +-- > = <"unbound"|[binding,...]> +-- +-- where the event name must be a valid event name in the specified +-- 'KeyEvents' and each binding is valid as parsed by 'parseBinding'. +-- +-- Returns @Nothing@ if the named section was not found; otherwise +-- returns a (possibly empty) list of binding states for each event in +-- @evs@. +keybindingsFromIni :: KeyEvents k + -- ^ The key event name mapping to use to parse the + -- configuration data. + -> T.Text + -- ^ The name of the INI configuration section to + -- read. + -> T.Text + -- ^ The text of the INI document to read. + -> Either String (Maybe [(k, BindingState)]) +keybindingsFromIni evs section doc = + Ini.parseIniFile doc (keybindingIniParser evs section) + +-- | Parse custom key bindings from the specified INI file path. This +-- does not catch or convert any exceptions resulting from I/O errors. +-- See 'keybindingsFromIni' for details. +keybindingsFromFile :: KeyEvents k + -- ^ The key event name mapping to use to parse the + -- configuration data. + -> T.Text + -- ^ The name of the INI configuration section to + -- read. + -> FilePath + -- ^ The path to the INI file to read. + -> IO (Either String (Maybe [(k, BindingState)])) +keybindingsFromFile evs section path = + keybindingsFromIni evs section <$> T.readFile path + +-- | The low-level INI parser for custom key bindings used by this +-- module, exported for applications that use the @config-ini@ package. +keybindingIniParser :: KeyEvents k -> T.Text -> Ini.IniParser (Maybe [(k, BindingState)]) +keybindingIniParser evs section = + Ini.sectionMb section $ do + fmap catMaybes $ forM (keyEventsList evs) $ \(name, e) -> do + fmap (e,) <$> Ini.fieldMbOf name parseBindingList diff --git a/src/Brick/Keybindings/Pretty.hs b/src/Brick/Keybindings/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Keybindings/Pretty.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides functions for pretty-printing key bindings +-- and for generating Markdown, plain text, and Brick displays of event +-- handler key binding configurations. +module Brick.Keybindings.Pretty + ( + -- * Generating help output + keybindingTextTable + , keybindingMarkdownTable + , keybindingHelpWidget + + -- * Pretty-printing primitives + , ppBinding + , ppMaybeBinding + , ppKey + , ppModifier + + -- * Attributes for Widget rendering + , keybindingHelpBaseAttr + , eventNameAttr + , eventDescriptionAttr + , keybindingAttr + ) +where + +import Brick +import Data.List (sort, intersperse) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Graphics.Vty as Vty + +import Brick.Keybindings.KeyEvents +import Brick.Keybindings.KeyConfig +import Brick.Keybindings.KeyDispatcher + +data TextHunk = Verbatim T.Text + | Comment T.Text + +-- | Generate a Markdown document of sections indicating the key binding +-- state for each event handler. +keybindingMarkdownTable :: (Ord k) + => KeyConfig k + -- ^ The key binding configuration in use. + -> [(T.Text, [KeyEventHandler k m])] + -- ^ Key event handlers by named section. + -> T.Text +keybindingMarkdownTable kc sections = title <> keybindSectionStrings + where title = "# Keybindings\n" + keybindSectionStrings = T.concat $ sectionText <$> sections + sectionText (heading, handlers) = + mkHeading heading <> + mkKeybindEventSectionHelp kc keybindEventHelpMarkdown T.unlines handlers + mkHeading n = + "\n# " <> n <> + "\n| Keybinding | Event Name | Description |" <> + "\n| ---------- | ---------- | ----------- |\n" + +-- | Generate a plain text document of sections indicating the key +-- binding state for each event handler. +keybindingTextTable :: (Ord k) + => KeyConfig k + -- ^ The key binding configuration in use. + -> [(T.Text, [KeyEventHandler k m])] + -- ^ Key event handlers by named section. + -> T.Text +keybindingTextTable kc sections = title <> keybindSectionStrings + where title = "Keybindings\n===========\n" + keybindSectionStrings = T.concat $ sectionText <$> sections + sectionText (heading, handlers) = + mkHeading heading <> + mkKeybindEventSectionHelp kc (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines handlers + keybindingWidth = 15 + eventNameWidth = 30 + mkHeading n = + "\n" <> n <> + "\n" <> (T.replicate (T.length n) "=") <> + "\n" + +keybindEventHelpText :: Int -> Int -> (TextHunk, T.Text, [TextHunk]) -> T.Text +keybindEventHelpText width eventNameWidth (evName, desc, evs) = + let getText (Comment s) = s + getText (Verbatim s) = s + in padTo width (T.intercalate ", " $ getText <$> evs) <> " " <> + padTo eventNameWidth (getText evName) <> " " <> + desc + +padTo :: Int -> T.Text -> T.Text +padTo n s = s <> T.replicate (n - T.length s) " " + +mkKeybindEventSectionHelp :: (Ord k) + => KeyConfig k + -> ((TextHunk, T.Text, [TextHunk]) -> a) + -> ([a] -> a) + -> [KeyEventHandler k m] + -> a +mkKeybindEventSectionHelp kc mkKeybindHelpFunc vertCat kbs = + vertCat $ mkKeybindHelpFunc <$> (mkKeybindEventHelp kc <$> kbs) + +keybindEventHelpMarkdown :: (TextHunk, T.Text, [TextHunk]) -> T.Text +keybindEventHelpMarkdown (evName, desc, evs) = + let quote s = "`" <> s <> "`" + format (Comment s) = s + format (Verbatim s) = quote s + name = case evName of + Comment s -> s + Verbatim s -> quote s + in "| " <> (T.intercalate ", " $ format <$> evs) <> + " | " <> name <> + " | " <> desc <> + " |" + +mkKeybindEventHelp :: (Ord k) + => KeyConfig k + -> KeyEventHandler k m + -> (TextHunk, T.Text, [TextHunk]) +mkKeybindEventHelp kc h = + let trig = kehEventTrigger h + unbound = [Comment "(unbound)"] + (label, evText) = case trig of + ByKey b -> + (Comment "(non-customizable key)", [Verbatim $ ppBinding b]) + ByEvent ev -> + let name = maybe (Comment "(unnamed)") Verbatim $ keyEventName (keyConfigEvents kc) ev + in case lookupKeyConfigBindings kc ev of + Nothing -> + if not (null (allDefaultBindings kc ev)) + then (name, Verbatim <$> ppBinding <$> allDefaultBindings kc ev) + else (name, unbound) + Just Unbound -> + (name, unbound) + Just (BindingList bs) -> + let result = if not (null bs) + then Verbatim <$> ppBinding <$> bs + else unbound + in (name, result) + in (label, handlerDescription $ kehHandler h, evText) + +-- | Build a 'Widget' displaying key binding information for a single +-- related group of event handlers. This is provided for convenience +-- so that basic help text for the application's event handlers can be +-- produced and embedded in the UI. +-- +-- The resulting widget lists the key events (and keys) bound to the +-- specified handlers, along with the events' names and the list of +-- available key bindings for each handler. +keybindingHelpWidget :: (Ord k) + => KeyConfig k + -- ^ The key binding configuration in use. + -> [KeyEventHandler k m] + -- ^ The list of the event handlers to include in + -- the help display. + -> Widget n +keybindingHelpWidget kc = + withDefAttr keybindingHelpBaseAttr . + mkKeybindEventSectionHelp kc keybindEventHelpWidget (vBox . intersperse (str " ")) + +keybindEventHelpWidget :: (TextHunk, T.Text, [TextHunk]) -> Widget n +keybindEventHelpWidget (evName, desc, evs) = + let evText = T.intercalate ", " (getText <$> evs) + getText (Comment s) = s + getText (Verbatim s) = s + label = withDefAttr eventNameAttr $ case evName of + Comment s -> txt s + Verbatim s -> txt s + in vBox [ withDefAttr eventDescriptionAttr $ txt desc + , label <+> txt " = " <+> withDefAttr keybindingAttr (txt evText) + ] + +-- | Pretty-print a 'Binding' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppBinding :: Binding -> T.Text +ppBinding (Binding k mods) = + T.intercalate "-" $ (ppModifier <$> modifierList mods) <> [ppKey k] + +modifierList :: S.Set Vty.Modifier -> [Vty.Modifier] +modifierList = sort . S.toList + +-- | Pretty-print a 'Binding' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'; if no binding is given, +-- produce a message indicating no binding. +ppMaybeBinding :: Maybe Binding -> T.Text +ppMaybeBinding Nothing = + "(no binding)" +ppMaybeBinding (Just b) = + ppBinding b + +-- | Pretty-print a 'Vty.Key' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppKey :: Vty.Key -> T.Text +ppKey (Vty.KChar c) = ppChar c +ppKey (Vty.KFun n) = "F" <> (T.pack $ show n) +ppKey Vty.KBackTab = "BackTab" +ppKey Vty.KEsc = "Esc" +ppKey Vty.KBS = "Backspace" +ppKey Vty.KEnter = "Enter" +ppKey Vty.KUp = "Up" +ppKey Vty.KDown = "Down" +ppKey Vty.KLeft = "Left" +ppKey Vty.KRight = "Right" +ppKey Vty.KHome = "Home" +ppKey Vty.KEnd = "End" +ppKey Vty.KPageUp = "PgUp" +ppKey Vty.KPageDown = "PgDown" +ppKey Vty.KDel = "Del" +ppKey Vty.KUpLeft = "UpLeft" +ppKey Vty.KUpRight = "UpRight" +ppKey Vty.KDownLeft = "DownLeft" +ppKey Vty.KDownRight = "DownRight" +ppKey Vty.KCenter = "Center" +ppKey Vty.KPrtScr = "PrintScreen" +ppKey Vty.KPause = "Pause" +ppKey Vty.KIns = "Insert" +ppKey Vty.KBegin = "Begin" +ppKey Vty.KMenu = "Menu" + +-- | Pretty-print a character in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppChar :: Char -> T.Text +ppChar '\t' = "Tab" +ppChar ' ' = "Space" +ppChar c = T.singleton c + +-- | Pretty-print a 'Vty.Modifier' in the same format that is parsed by +-- 'Brick.Keybindings.Parse.parseBinding'. +ppModifier :: Vty.Modifier -> T.Text +ppModifier Vty.MMeta = "M" +ppModifier Vty.MAlt = "A" +ppModifier Vty.MCtrl = "C" +ppModifier Vty.MShift = "S" + +-- | The base attribute for 'Widget' keybinding help. +keybindingHelpBaseAttr :: AttrName +keybindingHelpBaseAttr = attrName "keybindingHelp" + +-- | The attribute for event names in keybinding help 'Widget's. +eventNameAttr :: AttrName +eventNameAttr = keybindingHelpBaseAttr <> attrName "eventName" + +-- | The attribute for event descriptions in keybinding help 'Widget's. +eventDescriptionAttr :: AttrName +eventDescriptionAttr = keybindingHelpBaseAttr <> attrName "eventDescription" + +-- | The attribute for keybinding lists in keybinding help 'Widget's. +keybindingAttr :: AttrName +keybindingAttr = keybindingHelpBaseAttr <> attrName "keybinding" diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -1,15 +1,26 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Brick.Main ( App(..) , defaultMain , customMain + , customMainWithVty + , customMainWithDefaultVty , simpleMain , resizeOrQuit + , simpleApp -- * Event handler functions - , continue + , continueWithoutRedraw , halt , suspendAndResume + , suspendAndResume' + , makeVisible , lookupViewport + , lookupExtent + , findClickedExtents + , clickedExtent + , getVtyHandle -- ** Viewport scrolling , viewportScroll @@ -22,24 +33,37 @@ , hScrollPage , hScrollToBeginning , hScrollToEnd + , setTop + , setLeft -- * Cursor management functions , neverShowCursor , showFirstCursor , showCursorNamed + + -- * Rendering cache management + , invalidateCacheEntry + , invalidateCache + + -- * Renderer internals (for benchmarking) + , renderFinal + , getRenderState + , resetRenderState + , renderWidget ) where -import Control.Exception (finally) -import Control.Lens ((^.)) -import Control.Monad (forever) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader -import Control.Concurrent (forkIO, Chan, newChan, readChan, writeChan, killThread) -import Data.Default +import qualified Control.Exception as E +import Lens.Micro ((^.), (&), (.~), (%~), _1, _2) +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Reader +import Control.Concurrent (forkIO, killThread) +import qualified Data.Foldable as F +import Data.List (find) import Data.Maybe (listToMaybe) import qualified Data.Map as M +import qualified Data.Set as S import Graphics.Vty ( Vty , Picture(..) @@ -50,26 +74,36 @@ , displayBounds , shutdown , nextEvent - , mkVty + , restoreInputState + , inputIface ) +import Graphics.Vty.CrossPlatform (mkVty) +import Graphics.Vty.Config (defaultConfig) +import Graphics.Vty.Attributes (defAttr) -import Brick.Types (Viewport, Direction, Widget, rowL, columnL, CursorLocation(..), cursorLocationNameL, Name(..), EventM) -import Brick.Types.Internal (ScrollRequest(..), RenderState(..), Next(..)) -import Brick.Widgets.Internal (renderFinal) +import Brick.BChan (BChan, newBChan, readBChan, readBChan2, writeBChan) +import Brick.Types.EventM +import Brick.Types.Internal +import Brick.Widgets.Internal import Brick.AttrMap -- | The library application abstraction. Your application's operations --- are represented here and passed to one of the various main functions --- in this module. An application is in terms of an application state --- type 's' and an application event type 'e'. In the simplest case 'e' is --- vty's 'Event' type, but you may define your own event type, permitted --- that it has a constructor for wrapping Vty events, so that Vty events --- can be handled by your event loop. -data App s e = - App { appDraw :: s -> [Widget] +-- are provided in an @App@ and then the @App@ is provided to one of the +-- various main functions in this module. An application @App s e n@ +-- is in terms of an application state type @s@, an application event +-- type @e@, and a resource name type @n@. In the simplest case 'e' is +-- unused (left polymorphic or set to @()@), but you may define your own +-- event type and use 'customMain' to provide custom events. The state +-- type @s@ is the type of application state to be provided by you and +-- iteratively modified by event handlers. The resource name type @n@ +-- is the type of names you can assign to rendering resources such as +-- viewports and cursor locations. Your application must define this +-- type. +data App s e n = + App { appDraw :: s -> [Widget n] -- ^ This function turns your application state into a list of -- widget layers. The layers are listed topmost first. - , appChooseCursor :: s -> [CursorLocation] -> Maybe CursorLocation + , appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n) -- ^ This function chooses which of the zero or more cursor -- locations reported by the rendering process should be -- selected as the one to use to place the cursor. If this @@ -77,228 +111,555 @@ -- is that many widgets may request a cursor placement but your -- application state is what you probably want to use to decide -- which one wins. - , appHandleEvent :: s -> e -> EventM (Next s) - -- ^ This function takes the current application state and an - -- event and returns an action to be taken and a corresponding - -- transformed application state. Possible options are - -- 'continue', 'suspendAndResume', and 'halt'. - , appStartEvent :: s -> EventM s + , appHandleEvent :: BrickEvent n e -> EventM n s () + -- ^ This function handles an event and updates the current + -- application state. + , appStartEvent :: EventM n s () -- ^ This function gets called once just prior to the first -- drawing of your application. Here is where you can make -- initial scrolling requests, for example. , appAttrMap :: s -> AttrMap -- ^ The attribute map that should be used during rendering. - , appLiftVtyEvent :: Event -> e - -- ^ The event constructor to use to wrap Vty events in your own - -- event type. For example, if the application's event type is - -- 'Event', this is just 'id'. } -- | The default main entry point which takes an application and an --- initial state and returns the final state returned by a 'halt' --- operation. -defaultMain :: App s Event +-- initial state and returns the final state from 'EventM' once the +-- program exits. +defaultMain :: (Ord n) + => App s e n -- ^ The application. -> s -- ^ The initial application state. -> IO s defaultMain app st = do - chan <- newChan - customMain (mkVty def) chan 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 -- resize events cause redraws. -simpleMain :: Widget +simpleMain :: (Ord n) + => Widget n -- ^ The widget to draw. -> IO () -simpleMain w = - let app = App { appDraw = const [w] - , appHandleEvent = resizeOrQuit - , appStartEvent = return - , appAttrMap = def - , appLiftVtyEvent = id - , appChooseCursor = neverShowCursor - } - in defaultMain app () +simpleMain w = defaultMain (simpleApp w) () +-- | A simple application with reasonable defaults to be overridden as +-- desired: +-- +-- * Draws only the specified widget +-- * Quits on any event other than resizes +-- * Has no start event handler +-- * Provides no attribute map +-- * Never shows any cursors +simpleApp :: Widget n -> App s e n +simpleApp w = + App { appDraw = const [w] + , appHandleEvent = resizeOrQuit + , appStartEvent = return () + , appAttrMap = const $ attrMap defAttr [] + , appChooseCursor = neverShowCursor + } + -- | An event-handling function which continues execution of the event -- loop only when resize events occur; all other types of events trigger -- a halt. This is a convenience function useful as an 'appHandleEvent' -- value for simple applications using the 'Event' type that do not need -- to get more sophisticated user input. -resizeOrQuit :: s -> Event -> EventM (Next s) -resizeOrQuit s (EvResize _ _) = continue s -resizeOrQuit s _ = halt s +resizeOrQuit :: BrickEvent n e -> EventM n s () +resizeOrQuit (VtyEvent (EvResize _ _)) = return () +resizeOrQuit _ = halt -data InternalNext a = InternalSuspendAndResume RenderState (IO a) - | InternalHalt a +readBrickEvent :: BChan (BrickEvent n e) -> BChan e -> IO (BrickEvent n e) +readBrickEvent brickChan userChan = either id AppEvent <$> readBChan2 brickChan userChan -runWithNewVty :: IO Vty -> Chan e -> App s e -> RenderState -> s -> IO (InternalNext s) -runWithNewVty buildVty chan app initialRS initialSt = do - withVty buildVty $ \vty -> do - pid <- forkIO $ supplyVtyEvents vty (appLiftVtyEvent app) chan - let runInner rs st = do - (result, newRS) <- runVty vty chan app st rs - case result of - SuspendAndResume act -> do - killThread pid - return $ InternalSuspendAndResume newRS act - Halt s -> do - killThread pid - return $ InternalHalt s - Continue s -> runInner newRS s - runInner initialRS initialSt +runWithVty :: (Ord n) + => VtyContext + -> BChan (BrickEvent n e) + -> Maybe (BChan e) + -> App s e n + -> RenderState n + -> s + -> IO (s, VtyContext) +runWithVty vtyCtx brickChan mUserChan app initialRS initialSt = do + let readEvent = case mUserChan of + Nothing -> readBChan brickChan + Just uc -> readBrickEvent brickChan uc + runInner ctx rs es draw st = do + let nextRS = if draw + then resetRenderState rs + else rs + (nextSt, result, newRS, newExtents, newCtx) <- runVty ctx readEvent app st nextRS es draw + case result of + Halt -> + return (nextSt, newCtx) + Continue -> + runInner newCtx newRS newExtents True nextSt + ContinueWithoutRedraw -> + runInner newCtx newRS newExtents False nextSt + runInner vtyCtx initialRS mempty True initialSt + -- | The custom event loop entry point to use when the simpler ones --- don't permit enough control. -customMain :: IO Vty - -- ^ An IO action to build a Vty handle. This is used to - -- build a Vty handle whenever the event loop begins or is - -- resumed after suspension. - -> Chan e +-- don't permit enough control. Returns the final application state +-- after the application halts. +-- +-- Note that this function guarantees that the terminal input state +-- prior to the first Vty initialization is the terminal input state +-- that is restored on shutdown (regardless of exceptions). +customMain :: (Ord n) + => Vty + -- ^ The initial Vty handle to use. + -> IO Vty + -- ^ An IO action to build a Vty handle. This is used + -- to build a Vty handle whenever the event loop needs + -- to reinitialize the terminal, e.g. on resume after + -- suspension. + -> 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). - -> App s e + -- 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 -customMain buildVty chan app initialAppState = do - let run rs st = do - result <- runWithNewVty buildVty chan app rs st - case result of - InternalHalt s -> return s - InternalSuspendAndResume newRS action -> do - newAppState <- action - run newRS newAppState +customMain initialVty buildVty mUserChan app initialAppState = do + let restoreInitialState = restoreInputState $ inputIface initialVty - (st, initialScrollReqs) <- runStateT (runReaderT (appStartEvent app initialAppState) M.empty) [] - let initialRS = RS M.empty initialScrollReqs - run initialRS st + (s, vty) <- customMainWithVty initialVty buildVty mUserChan app initialAppState + `E.catch` (\(e::E.SomeException) -> restoreInitialState >> E.throw e) -supplyVtyEvents :: Vty -> (Event -> e) -> Chan e -> IO () -supplyVtyEvents vty mkEvent chan = - forever $ do - e <- nextEvent vty - writeChan chan $ mkEvent e + shutdown vty + restoreInitialState + return s -runVty :: Vty -> Chan e -> App s e -> s -> RenderState -> IO (Next s, RenderState) -runVty vty chan app appState rs = do - firstRS <- renderApp vty app appState rs - e <- readChan chan - (next, scrollReqs) <- runStateT (runReaderT (appHandleEvent app appState e) (viewportMap rs)) [] - return (next, firstRS { scrollRequests = scrollReqs }) +-- | 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 +-- as another Brick application. +customMainWithVty :: (Ord n) + => Vty + -- ^ The initial Vty handle to use. + -> IO Vty + -- ^ An IO action to build a Vty handle. This is used + -- to build a Vty handle whenever the event loop needs + -- to reinitialize the terminal, e.g. on resume after + -- suspension. + -> 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) +customMainWithVty initialVty buildVty mUserChan app initialAppState = do + brickChan <- newBChan 20 + vtyCtx <- newVtyContext buildVty (Just initialVty) (writeBChan brickChan . VtyEvent) + + let emptyES = ES { esScrollRequests = [] + , cacheInvalidateRequests = mempty + , requestedVisibleNames = mempty + , nextAction = Continue + , vtyContext = vtyCtx + } + emptyRS = RS M.empty mempty S.empty mempty mempty mempty mempty + eventRO = EventRO M.empty mempty emptyRS + + (((), appState), eState) <- runStateT (runStateT (runReaderT (runEventM (appStartEvent app)) eventRO) initialAppState) emptyES + let initialRS = RS { viewportMap = M.empty + , rsScrollRequests = esScrollRequests eState + , observedNames = S.empty + , renderCache = mempty + , clickableNames = [] + , requestedVisibleNames_ = requestedVisibleNames eState + , reportedExtents = mempty + } + + (s, ctx) <- runWithVty vtyCtx brickChan mUserChan app initialRS appState + `E.catch` (\(e::E.SomeException) -> shutdownVtyContext vtyCtx >> E.throw e) + + -- Shut down the context's event thread but do NOT shut down Vty + -- itself because we want the handle to be live when we return it to + -- the caller. + shutdownVtyContextThread ctx + return (s, vtyContextHandle ctx) + +supplyVtyEvents :: Vty -> (Event -> IO ()) -> IO () +supplyVtyEvents vty putEvent = + forever $ putEvent =<< nextEvent vty + +newVtyContextFrom :: VtyContext -> IO VtyContext +newVtyContextFrom old = + newVtyContext (vtyContextBuilder old) Nothing (vtyContextPutEvent old) + +newVtyContext :: IO Vty -> Maybe Vty -> (Event -> IO ()) -> IO VtyContext +newVtyContext builder handle putEvent = do + vty <- case handle of + Just h -> return h + Nothing -> builder + tId <- forkIO $ supplyVtyEvents vty putEvent + return VtyContext { vtyContextHandle = vty + , vtyContextBuilder = builder + , vtyContextThread = tId + , vtyContextPutEvent = putEvent + } + +shutdownVtyContext :: VtyContext -> IO () +shutdownVtyContext ctx = do + shutdown $ vtyContextHandle ctx + shutdownVtyContextThread ctx + +shutdownVtyContextThread :: VtyContext -> IO () +shutdownVtyContextThread ctx = + killThread $ vtyContextThread ctx + +runVty :: (Ord n) + => VtyContext + -> IO (BrickEvent n e) + -> App s e n + -> s + -> RenderState n + -> [Extent n] + -> Bool + -> IO (s, NextAction, RenderState n, [Extent n], VtyContext) +runVty vtyCtx readEvent app appState rs prevExtents draw = do + (firstRS, exts) <- if draw + then renderApp vtyCtx app appState rs + else return (rs, prevExtents) + + e <- readEvent + + (e', nextRS, nextExts) <- case e of + -- If the event was a resize, redraw the UI to update the + -- viewport states before we invoke the event handler since we + -- want the event handler to have access to accurate viewport + -- information. + VtyEvent (EvResize _ _) -> do + (rs', exts') <- renderApp vtyCtx app appState $ firstRS & observedNamesL .~ S.empty + return (e, rs', exts') + VtyEvent (EvMouseDown c r button mods) -> do + let matching = findClickedExtents_ (c, r) exts + case matching of + (Extent n (Location (ec, er)) _:_) -> + -- If the clicked extent was registered as + -- clickable, send a click event. Otherwise, just + -- send the raw mouse event + if n `elem` firstRS^.clickableNamesL + then do + let localCoords = Location (lc, lr) + lc = c - ec + lr = r - er + + -- If the clicked extent was a viewport, + -- adjust the local coordinates by + -- adding the viewport upper-left corner + -- offset. + newCoords = case M.lookup n (viewportMap firstRS) of + Nothing -> localCoords + Just vp -> localCoords & _1 %~ (+ (vp^.vpLeft)) + & _2 %~ (+ (vp^.vpTop)) + + return (MouseDown n button mods newCoords, firstRS, exts) + else return (e, firstRS, exts) + _ -> return (e, firstRS, exts) + VtyEvent (EvMouseUp c r button) -> do + let matching = findClickedExtents_ (c, r) exts + case matching of + (Extent n (Location (ec, er)) _:_) -> + -- If the clicked extent was registered as + -- clickable, send a click event. Otherwise, just + -- send the raw mouse event + if n `elem` firstRS^.clickableNamesL + then do + let localCoords = Location (lc, lr) + lc = c - ec + lr = r - er + -- If the clicked extent was a viewport, + -- adjust the local coordinates by + -- adding the viewport upper-left corner + -- offset. + newCoords = case M.lookup n (viewportMap firstRS) of + Nothing -> localCoords + Just vp -> localCoords & _1 %~ (+ (vp^.vpLeft)) + & _2 %~ (+ (vp^.vpTop)) + return (MouseUp n button newCoords, firstRS, exts) + else return (e, firstRS, exts) + _ -> return (e, firstRS, exts) + _ -> return (e, firstRS, exts) + + let emptyES = ES [] mempty mempty Continue vtyCtx + eventRO = EventRO (viewportMap nextRS) nextExts nextRS + + (((), newAppState), eState) <- runStateT (runStateT (runReaderT (runEventM (appHandleEvent app e')) + eventRO) appState) emptyES + return ( newAppState + , nextAction eState + , nextRS { rsScrollRequests = esScrollRequests eState + , renderCache = applyInvalidations (cacheInvalidateRequests eState) $ + renderCache nextRS + , requestedVisibleNames_ = requestedVisibleNames eState + } + , nextExts + , vtyContext eState + ) + +applyInvalidations :: (Ord n) => S.Set (CacheInvalidateRequest n) -> M.Map n v -> M.Map n v +applyInvalidations ns cache = + if InvalidateEntire `S.member` ns + then mempty + else foldr (.) id (mkFunc <$> F.toList ns) cache + where + mkFunc InvalidateEntire = const mempty + mkFunc (InvalidateSingle n) = M.delete n + -- | Given a viewport name, get the viewport's size and offset -- information from the most recent rendering. Returns 'Nothing' if -- no such state could be found, either because the name was invalid -- or because no rendering has occurred (e.g. in an 'appStartEvent' --- handler). -lookupViewport :: Name -> EventM (Maybe Viewport) -lookupViewport = asks . M.lookup +-- handler). An important consequence of this behavior is that if this +-- function is called before a viewport is rendered for the first +-- time, no state will be found because the renderer only knows about +-- viewports it has rendered in the most recent rendering. As a result, +-- if you need to make viewport transformations before they are drawn +-- for the first time, you may need to use 'viewportScroll' and its +-- associated functions without relying on this function. Those +-- functions queue up scrolling requests that can be made in advance of +-- the next rendering to affect the viewport. +lookupViewport :: (Ord n) => n -> EventM n s (Maybe Viewport) +lookupViewport n = EventM $ asks (M.lookup n . eventViewportMap) -withVty :: IO Vty -> (Vty -> IO a) -> IO a -withVty buildVty useVty = do - vty <- buildVty - useVty vty `finally` shutdown vty +-- | 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)) = + c >= lc && c < (lc + w) && + r >= lr && r < (lr + h) -renderApp :: Vty -> App s e -> s -> RenderState -> IO RenderState -renderApp vty app appState rs = do - sz <- displayBounds $ outputIface vty - let (newRS, pic, theCursor) = renderFinal (appAttrMap app appState) - (appDraw app appState) - sz - (appChooseCursor app appState) - rs +-- | 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) + where + f (Extent n' _ _) = n == n' + +-- | Given a mouse click location, return the extents intersected by the +-- click. The returned extents are sorted such that the first extent in +-- the list is the most specific extent and the last extent is the most +-- generic (top-level). So if two extents A and B both intersected the +-- mouse click but A contains B, then they would be returned [B, A]. +findClickedExtents :: (Int, Int) -> EventM n s [Extent n] +findClickedExtents pos = EventM $ asks (findClickedExtents_ pos . latestExtents) + +findClickedExtents_ :: (Int, Int) -> [Extent n] -> [Extent n] +findClickedExtents_ pos = reverse . filter (clickedExtent pos) + +-- | Get the Vty handle currently in use. +getVtyHandle :: EventM n s Vty +getVtyHandle = vtyContextHandle <$> getVtyContext + +setVtyContext :: VtyContext -> EventM n s () +setVtyContext ctx = + EventM $ lift $ lift $ modify $ \s -> s { vtyContext = ctx } + +-- | Invalidate the rendering cache entry with the specified resource +-- name. +invalidateCacheEntry :: (Ord n) => n -> EventM n s () +invalidateCacheEntry n = EventM $ do + lift $ lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s }) + +-- | Invalidate the entire rendering cache. +invalidateCache :: (Ord n) => EventM n s () +invalidateCache = EventM $ do + lift $ lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s }) + +getRenderState :: EventM n s (RenderState n) +getRenderState = EventM $ asks oldState + +resetRenderState :: 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 vtyCtx app appState rs = do + sz <- displayBounds $ outputIface $ vtyContextHandle vtyCtx + let (newRS, pic, theCursor, exts) = renderFinal (appAttrMap app appState) + (appDraw app appState) + sz + (appChooseCursor app appState) + rs picWithCursor = case theCursor of Nothing -> pic { picCursor = NoCursor } - Just loc -> pic { picCursor = Cursor (loc^.columnL) (loc^.rowL) } + Just cloc -> pic { picCursor = (if cursorLocationVisible cloc + then AbsoluteCursor + else PositionOnly True) + (cloc^.locationColumnL) + (cloc^.locationRowL) + } - update vty picWithCursor + update (vtyContextHandle vtyCtx) picWithCursor - return newRS + return (newRS, exts) -- | Ignore all requested cursor positions returned by the rendering -- process. This is a convenience function useful as an -- 'appChooseCursor' value when a simple application has no need to -- position the cursor. -neverShowCursor :: s -> [CursorLocation] -> Maybe CursorLocation +neverShowCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n) neverShowCursor = const $ const Nothing -- | Always show the first cursor, if any, returned by the rendering -- process. This is a convenience function useful as an -- 'appChooseCursor' value when a simple program has zero or more -- widgets that advertise a cursor position. -showFirstCursor :: s -> [CursorLocation] -> Maybe CursorLocation +showFirstCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n) showFirstCursor = const listToMaybe --- | Show the cursor with the specified name, if such a cursor location --- has been reported. -showCursorNamed :: Name -> [CursorLocation] -> Maybe CursorLocation +-- | Show the cursor with the specified resource name, if such a cursor +-- location has been reported. +showCursorNamed :: (Eq n) => n -> [CursorLocation n] -> Maybe (CursorLocation n) showCursorNamed name locs = - let matches loc = loc^.cursorLocationNameL == Just name - in listToMaybe $ filter matches locs + let matches l = l^.cursorLocationNameL == Just name + in find matches locs -- | A viewport scrolling handle for managing the scroll state of -- viewports. -data ViewportScroll = - ViewportScroll { viewportName :: Name +data ViewportScroll n = + ViewportScroll { viewportName :: n -- ^ The name of the viewport to be controlled by -- this scrolling handle. - , hScrollPage :: Direction -> EventM () + , hScrollPage :: forall s. Direction -> EventM n s () -- ^ Scroll the viewport horizontally by one page in -- the specified direction. - , hScrollBy :: Int -> EventM () + , hScrollBy :: forall s. Int -> EventM n s () -- ^ Scroll the viewport horizontally by the -- specified number of rows or columns depending on -- the orientation of the viewport. - , hScrollToBeginning :: EventM () + , hScrollToBeginning :: forall s. EventM n s () -- ^ Scroll horizontally to the beginning of the -- viewport. - , hScrollToEnd :: EventM () + , hScrollToEnd :: forall s. EventM n s () -- ^ Scroll horizontally to the end of the viewport. - , vScrollPage :: Direction -> EventM () + , vScrollPage :: forall s. Direction -> EventM n s () -- ^ Scroll the viewport vertically by one page in -- the specified direction. - , vScrollBy :: Int -> EventM () + , vScrollBy :: forall s. Int -> EventM n s () -- ^ Scroll the viewport vertically by the specified -- number of rows or columns depending on the -- orientation of the viewport. - , vScrollToBeginning :: EventM () + , vScrollToBeginning :: forall s. EventM n s () -- ^ Scroll vertically to the beginning of the viewport. - , vScrollToEnd :: EventM () + , vScrollToEnd :: forall s. EventM n s () -- ^ Scroll vertically to the end of the viewport. + , setTop :: forall s. Int -> EventM n s () + -- ^ Set the top row offset of the viewport. + , setLeft :: forall s. Int -> EventM n s () + -- ^ Set the left column offset of the viewport. } +addScrollRequest :: (n, ScrollRequest) -> EventM n s () +addScrollRequest req = EventM $ do + lift $ lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s }) + -- | Build a viewport scroller for the viewport with the specified name. -viewportScroll :: Name -> ViewportScroll +viewportScroll :: n -> ViewportScroll n viewportScroll n = - ViewportScroll { viewportName = n - , hScrollPage = \dir -> lift $ modify ((n, HScrollPage dir) :) - , hScrollBy = \i -> lift $ modify ((n, HScrollBy i) :) - , hScrollToBeginning = lift $ modify ((n, HScrollToBeginning) :) - , hScrollToEnd = lift $ modify ((n, HScrollToEnd) :) - , vScrollPage = \dir -> lift $ modify ((n, VScrollPage dir) :) - , vScrollBy = \i -> lift $ modify ((n, VScrollBy i) :) - , vScrollToBeginning = lift $ modify ((n, VScrollToBeginning) :) - , vScrollToEnd = lift $ modify ((n, VScrollToEnd) :) + ViewportScroll { viewportName = n + , hScrollPage = \dir -> addScrollRequest (n, HScrollPage dir) + , hScrollBy = \i -> addScrollRequest (n, HScrollBy i) + , hScrollToBeginning = addScrollRequest (n, HScrollToBeginning) + , hScrollToEnd = addScrollRequest (n, HScrollToEnd) + , vScrollPage = \dir -> addScrollRequest (n, VScrollPage dir) + , vScrollBy = \i -> addScrollRequest (n, VScrollBy i) + , vScrollToBeginning = addScrollRequest (n, VScrollToBeginning) + , vScrollToEnd = addScrollRequest (n, VScrollToEnd) + , setTop = \i -> addScrollRequest (n, SetTop i) + , setLeft = \i -> addScrollRequest (n, SetLeft i) } -- | Continue running the event loop with the specified application --- state. -continue :: s -> EventM (Next s) -continue = return . Continue +-- state without redrawing the screen. This is faster than 'continue' +-- because it skips the redraw, but the drawback is that you need to +-- be really sure that you don't want a screen redraw. If your state +-- changed in a way that needs to be reflected on the screen, just don't +-- call this; 'EventM' blocks default to triggering redraws when they +-- finish executing. This function is for cases where you know that you +-- did something that won't have an impact on the screen state and you +-- want to save on redraw cost. +continueWithoutRedraw :: EventM n s () +continueWithoutRedraw = + EventM $ lift $ lift $ modify $ \es -> es { nextAction = ContinueWithoutRedraw } -- | Halt the event loop and return the specified application state as -- the final state value. -halt :: s -> EventM (Next s) -halt = return . Halt +halt :: EventM n s () +halt = + EventM $ lift $ lift $ modify $ \es -> es { nextAction = Halt } -- | Suspend the event loop, save the terminal state, and run the -- specified action. When it returns an application state value, restore --- the terminal state, redraw the application from the new state, and --- resume the event loop. -suspendAndResume :: IO s -> EventM (Next s) -suspendAndResume = return . SuspendAndResume +-- the terminal state, empty the rendering cache, update the application +-- state with the returned state, and continue execution of the event +-- handler that called this. +-- +-- Note that any changes made to the terminal's input state are ignored +-- when Brick resumes execution and are not preserved in the final +-- terminal input state after the Brick application returns the terminal +-- to the user. +suspendAndResume :: (Ord n) => IO s -> EventM n s () +suspendAndResume act = suspendAndResume' act >>= put + +-- | Suspend the event loop, save the terminal state, and run the +-- specified action. When it completes, restore the terminal state, +-- empty the rendering cache, return the result, and continue execution +-- of the event handler that called this. +-- +-- Note that any changes made to the terminal's input state are ignored +-- when Brick resumes execution and are not preserved in the final +-- terminal input state after the Brick application returns the terminal +-- to the user. +suspendAndResume' :: (Ord n) => IO a -> EventM n s a +suspendAndResume' act = do + ctx <- getVtyContext + liftIO $ shutdownVtyContext ctx + result <- liftIO act + setVtyContext =<< (liftIO $ newVtyContextFrom ctx) + invalidateCache + return result + +-- | Request that the specified UI element be made visible on the +-- next rendering. This is provided to allow event handlers to make +-- visibility requests in the same way that the 'visible' function does +-- at rendering time. +makeVisible :: (Ord n) => n -> EventM n s () +makeVisible n = EventM $ do + lift $ lift $ modify (\s -> s { requestedVisibleNames = S.insert n $ requestedVisibleNames s }) diff --git a/src/Brick/Markup.hs b/src/Brick/Markup.hs deleted file mode 100644 --- a/src/Brick/Markup.hs +++ /dev/null @@ -1,54 +0,0 @@ --- | This module provides an API for turning "markup" values into --- widgets. This module uses the Data.Text.Markup interface in this --- package to assign attributes to substrings in a text string; to --- manipulate markup using (for example) syntax highlighters, see that --- module. -module Brick.Markup - ( Markup - , markup - , (@?) - , GetAttr(..) - ) -where - -import Control.Lens ((.~), (&), (^.)) -import Control.Monad (forM) -import qualified Data.Text as T -import Data.Text.Markup -import Data.Default (def) - -import Graphics.Vty (Attr, horizCat, string) - -import Brick.AttrMap -import Brick.Types - --- | A type class for types that provide access to an attribute in the --- rendering monad. You probably won't need to instance this. -class GetAttr a where - -- | Where to get the attribute for this attribute metadata. - getAttr :: a -> RenderM Attr - -instance GetAttr Attr where - getAttr a = do - c <- getContext - return $ mergeWithDefault a (c^.ctxAttrMapL) - -instance GetAttr AttrName where - getAttr = lookupAttrName - --- | Build a piece of markup from text with an assigned attribute name. --- When the markup is rendered, the attribute name will be looked up in --- the rendering context's 'AttrMap' to determine the attribute to use --- for this piece of text. -(@?) :: T.Text -> AttrName -> Markup AttrName -(@?) = (@@) - --- | Build a widget from markup. -markup :: (Eq a, GetAttr a) => Markup a -> Widget -markup m = - Widget Fixed Fixed $ do - let pairs = markupToList m - imgs <- forM pairs $ \(t, aSrc) -> do - a <- getAttr aSrc - return $ string a $ T.unpack t - return $ def & imageL .~ horizCat imgs diff --git a/src/Brick/Themes.hs b/src/Brick/Themes.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Themes.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Support for representing attribute themes and loading and saving +-- theme customizations in INI-style files. +-- +-- Customization files are INI-style files with two sections, both +-- optional: @"default"@ and @"other"@. +-- +-- The @"default"@ section specifies three optional fields: +-- +-- * @"default.fg"@ - a color specification +-- * @"default.bg"@ - a color specification +-- * @"default.style"@ - a style specification +-- +-- A color specification can be any of the strings @black@, @red@, +-- @green@, @yellow@, @blue@, @magenta@, @cyan@, @white@, @brightBlack@, +-- @brightRed@, @brightGreen@, @brightYellow@, @brightBlue@, +-- @brightMagenta@, @brightCyan@, @brightWhite@, or @default@. +-- +-- We also support color specifications in the common hex format @#RRGGBB@, but +-- note that this specification is lossy: terminals can only display 256 colors, +-- but hex codes can specify @256^3 = 16777216@ colors. +-- +-- A style specification can be either one of the following values +-- (without quotes) or a comma-delimited list of one or more of the +-- following values (e.g. @"[bold,underline]"@) indicating that all +-- of the specified styles be used. Valid styles are @standout@, +-- @underline@, @reverseVideo@, @blink@, @dim@, @italic@, +-- @strikethrough@, and @bold@. +-- +-- The @other@ section specifies for each attribute name in the theme +-- the same @fg@, @bg@, and @style@ settings as for the default +-- attribute. Furthermore, if an attribute name has multiple components, +-- the fields in the INI file should use periods as delimiters. For +-- example, if a theme has an attribute name (@attrName "foo" <> attrName "bar"@), then +-- the file may specify three fields: +-- +-- * @foo.bar.fg@ - a color specification +-- * @foo.bar.bg@ - a color specification +-- * @foo.bar.style@ - a style specification +-- +-- Any color or style specifications omitted from the file mean that +-- those attribute or style settings will use the theme's default value +-- instead. +-- +-- Attribute names with multiple components (e.g. @attr1 <> attr2@) can +-- be referenced in customization files by separating the names with +-- a dot. For example, the attribute name @attrName "list" <> attrName "selected"@ can be +-- referenced by using the string "list.selected". +module Brick.Themes + ( CustomAttr(..) + , customFgL + , customBgL + , customStyleL + + , Theme(..) + , newTheme + , themeDefaultAttrL + , themeDefaultMappingL + , themeCustomMappingL + , themeCustomDefaultAttrL + + , ThemeDocumentation(..) + , themeDescriptionsL + + , themeToAttrMap + , applyCustomizations + , loadCustomizations + , saveCustomizations + , saveTheme + ) +where + +import GHC.Generics (Generic) +import Graphics.Vty hiding ((<|>)) +import Control.DeepSeq +import Control.Monad (forM, join) +import Control.Applicative ((<|>)) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import qualified Data.Text.IO as T +import qualified Data.Map as M +import qualified Data.Semigroup as Sem +import Data.Tuple (swap) +import Data.List (intercalate) +import Data.Bits ((.|.), (.&.)) +import Data.Maybe (fromMaybe, isNothing, catMaybes, mapMaybe) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import qualified Data.Foldable as F + +import Data.Ini.Config + +import Brick.AttrMap (AttrMap, AttrName, attrMap, attrNameComponents) +import Brick.Types.TH (suffixLenses) + +import Text.Printf + +-- | An attribute customization can specify which aspects of an +-- attribute to customize. +data CustomAttr = + CustomAttr { customFg :: Maybe (MaybeDefault Color) + -- ^ The customized foreground, if any. + , customBg :: Maybe (MaybeDefault Color) + -- ^ The customized background, if any. + , customStyle :: Maybe Style + -- ^ The customized style, if any. + } + deriving (Eq, Read, Show, Generic, NFData) + +instance Sem.Semigroup CustomAttr where + a <> b = + CustomAttr { customFg = customFg a <|> customFg b + , customBg = customBg a <|> customBg b + , customStyle = customStyle a <|> customStyle b + } + +instance Monoid CustomAttr where + mempty = CustomAttr Nothing Nothing Nothing + mappend = (Sem.<>) + +-- | Documentation for a theme's attributes. +data ThemeDocumentation = + ThemeDocumentation { themeDescriptions :: M.Map AttrName T.Text + -- ^ The per-attribute documentation for a theme + -- so e.g. documentation for theme customization + -- can be generated mechanically. + } + deriving (Eq, Read, Show, Generic, NFData) + +-- | A theme provides a set of default attribute mappings, a default +-- attribute, and a set of customizations for the default mapping +-- and default attribute. The idea here is that the application will +-- always need to provide a complete specification of its attribute +-- mapping, but if the user wants to customize any aspect of that +-- default mapping, it can be contained here and then built into an +-- 'AttrMap' (see 'themeToAttrMap'). We keep the defaults separate +-- from customizations to permit users to serialize themes and their +-- customizations to, say, disk files. +data Theme = + Theme { themeDefaultAttr :: Attr + -- ^ The default attribute to use. + , themeDefaultMapping :: M.Map AttrName Attr + -- ^ The default attribute mapping to use. + , themeCustomDefaultAttr :: Maybe CustomAttr + -- ^ Customization for the theme's default attribute. + , themeCustomMapping :: M.Map AttrName CustomAttr + -- ^ Customizations for individual entries of the default + -- mapping. Note that this will only affect entries in the + -- default mapping; any attributes named here that are not + -- present in the default mapping will not be considered. + } + deriving (Eq, Read, Show, Generic, NFData) + +suffixLenses ''CustomAttr +suffixLenses ''Theme +suffixLenses ''ThemeDocumentation + +defaultSectionName :: T.Text +defaultSectionName = "default" + +otherSectionName :: T.Text +otherSectionName = "other" + +-- | Create a new theme with the specified default attribute and +-- attribute mapping. The theme will have no customizations. +newTheme :: Attr -> [(AttrName, Attr)] -> Theme +newTheme def mapping = + Theme { themeDefaultAttr = def + , themeDefaultMapping = M.fromList mapping + , themeCustomDefaultAttr = Nothing + , themeCustomMapping = mempty + } + +-- | Build an 'AttrMap' from a 'Theme'. This applies all customizations +-- in the returned 'AttrMap'. +themeToAttrMap :: Theme -> AttrMap +themeToAttrMap t = + attrMap (customizeAttr (themeCustomDefaultAttr t) (themeDefaultAttr t)) customMap + where + customMap = F.foldr f [] (M.toList $ themeDefaultMapping t) + f (aName, attr) mapping = + let a' = customizeAttr (M.lookup aName (themeCustomMapping t)) attr + in (aName, a'):mapping + +customizeAttr :: Maybe CustomAttr -> Attr -> Attr +customizeAttr Nothing a = a +customizeAttr (Just c) a = + let fg = fromMaybe (attrForeColor a) (customFg c) + bg = fromMaybe (attrBackColor a) (customBg c) + sty = maybe (attrStyle a) SetTo (customStyle c) + in a { attrForeColor = fg + , attrBackColor = bg + , attrStyle = sty + } + +isNullCustomization :: CustomAttr -> Bool +isNullCustomization c = + isNothing (customFg c) && + isNothing (customBg c) && + isNothing (customStyle c) + +-- | This function is lossy in the sense that we only internally support 240 colors but +-- the #RRGGBB format supports 16^3 colors. +parseColor :: T.Text -> Either String (MaybeDefault Color) +parseColor s = + let stripped = T.strip $ T.toLower s + normalize (t, c) = (T.toLower t, c) + in if stripped == "default" + then Right Default + else case parseRGB stripped of + Just c -> Right (SetTo c) + Nothing -> maybe (Left $ "Invalid color: " <> show stripped) (Right . SetTo) $ + lookup stripped (normalize <$> swap <$> allColors) + where + parseRGB t = if T.head t /= '#' + then Nothing + else case mapMaybe readHex (T.chunksOf 2 (T.tail t)) of + [r,g,b] -> Just (rgbColor r g b) + _ -> Nothing + + readHex :: T.Text -> Maybe Int + readHex t = either (const Nothing) (Just . fst) (T.hexadecimal t) + +allColors :: [(Color, T.Text)] +allColors = + [ (black, "black") + , (red, "red") + , (green, "green") + , (yellow, "yellow") + , (blue, "blue") + , (magenta, "magenta") + , (cyan, "cyan") + , (white, "white") + , (brightBlack, "brightBlack") + , (brightRed, "brightRed") + , (brightGreen, "brightGreen") + , (brightYellow, "brightYellow") + , (brightBlue, "brightBlue") + , (brightMagenta, "brightMagenta") + , (brightCyan, "brightCyan") + , (brightWhite, "brightWhite") + ] + +allStyles :: [(T.Text, Style)] +allStyles = + [ ("standout", standout) + , ("underline", underline) + , ("strikethrough", strikethrough) + , ("reversevideo", reverseVideo) + , ("blink", blink) + , ("dim", dim) + , ("bold", bold) + , ("italic", italic) + ] + +parseStyle :: T.Text -> Either String Style +parseStyle s = + let lookupStyle "" = Right Nothing + lookupStyle n = case lookup n normalizedStyles of + Just sty -> Right $ Just sty + Nothing -> Left $ T.unpack $ "Invalid style: " <> n + stripped = T.strip $ T.toLower s + normalize (n, a) = (T.toLower n, a) + normalizedStyles = normalize <$> allStyles + bracketed = "[" `T.isPrefixOf` stripped && + "]" `T.isSuffixOf` stripped + unbracketed = T.tail $ T.init stripped + parseStyleList = do + ss <- mapM lookupStyle $ T.strip <$> T.splitOn "," unbracketed + return $ foldr (.|.) 0 $ catMaybes ss + + in if bracketed + then parseStyleList + else do + result <- lookupStyle stripped + case result of + Nothing -> Left $ "Invalid style: " <> show stripped + Just sty -> Right sty + +themeParser :: Theme -> IniParser (Maybe CustomAttr, M.Map AttrName CustomAttr) +themeParser t = do + let parseCustomAttr basename = do + c <- CustomAttr <$> fieldMbOf (basename <> ".fg") parseColor + <*> fieldMbOf (basename <> ".bg") parseColor + <*> fieldMbOf (basename <> ".style") parseStyle + return $ if isNullCustomization c then Nothing else Just c + + defCustom <- sectionMb defaultSectionName $ do + parseCustomAttr "default" + + customMap <- sectionMb otherSectionName $ do + catMaybes <$> (forM (M.keys $ themeDefaultMapping t) $ \an -> + (fmap (an,)) <$> parseCustomAttr (makeFieldName $ attrNameComponents an) + ) + + return (join defCustom, M.fromList $ fromMaybe [] customMap) + +-- | Apply customizations using a custom lookup function. Customizations +-- are obtained for each attribute name in the theme. Any customizations +-- already set are lost. +applyCustomizations :: Maybe CustomAttr + -- ^ An optional customization for the theme's + -- default attribute. + -> (AttrName -> Maybe CustomAttr) + -- ^ A function to obtain a customization for the + -- specified attribute. + -> Theme + -- ^ The theme to customize. + -> Theme +applyCustomizations customDefAttr lookupAttr t = + let customMap = foldr nextAttr mempty (M.keys $ themeDefaultMapping t) + nextAttr an m = case lookupAttr an of + Nothing -> m + Just custom -> M.insert an custom m + in t { themeCustomDefaultAttr = customDefAttr + , themeCustomMapping = customMap + } + +-- | Load an INI file containing theme customizations. Use the specified +-- theme to determine which customizations to load. Return the specified +-- theme with customizations set. See the module documentation for the +-- theme file format. +loadCustomizations :: FilePath -> Theme -> IO (Either String Theme) +loadCustomizations path t = do + content <- T.readFile path + case parseIniFile content (themeParser t) of + Left e -> return $ Left e + Right (customDef, customMap) -> + return $ Right $ applyCustomizations customDef (flip M.lookup customMap) t + +vtyColorName :: Color -> T.Text +vtyColorName c@(Color240 n) = case color240CodeToRGB (fromIntegral n) of + Just (r,g,b) -> T.pack (printf "#%02x%02x%02x" r g b) + Nothing -> (error $ "Invalid color: " <> show c) +vtyColorName c = + fromMaybe (error $ "Invalid color: " <> show c) + (lookup c allColors) + +makeFieldName :: [String] -> T.Text +makeFieldName cs = T.pack $ intercalate "." cs + +serializeCustomColor :: [String] -> MaybeDefault Color -> T.Text +serializeCustomColor cs cc = + let cName = case cc of + Default -> "default" + SetTo c -> vtyColorName c + KeepCurrent -> error "serializeCustomColor does not support KeepCurrent" + in makeFieldName cs <> " = " <> cName + +serializeCustomStyle :: [String] -> Style -> T.Text +serializeCustomStyle cs s = + let activeStyles = filter (\(_, a) -> a .&. s == a) allStyles + styleStr = case activeStyles of + [(single, _)] -> single + many -> "[" <> (T.intercalate ", " $ fst <$> many) <> "]" + in makeFieldName cs <> " = " <> styleStr + +serializeCustomAttr :: [String] -> CustomAttr -> [T.Text] +serializeCustomAttr cs c = + catMaybes [ serializeCustomColor (cs <> ["fg"]) <$> customFg c + , serializeCustomColor (cs <> ["bg"]) <$> customBg c + , serializeCustomStyle (cs <> ["style"]) <$> customStyle c + ] + +emitSection :: T.Text -> [T.Text] -> [T.Text] +emitSection _ [] = [] +emitSection secName ls = ("[" <> secName <> "]") : ls + +-- | Save an INI file containing theme customizations. Use the specified +-- theme to determine which customizations to save. See the module +-- documentation for the theme file format. +saveCustomizations :: FilePath -> Theme -> IO () +saveCustomizations path t = do + let defSection = fromMaybe [] $ + serializeCustomAttr ["default"] <$> themeCustomDefaultAttr t + mapSection = concat $ flip map (M.keys $ themeDefaultMapping t) $ \an -> + maybe [] (serializeCustomAttr (attrNameComponents an)) $ + M.lookup an $ themeCustomMapping t + content = T.unlines $ (emitSection defaultSectionName defSection) <> + (emitSection otherSectionName mapSection) + T.writeFile path content + +-- | Save an INI file containing all attributes from the specified +-- theme. Customized attributes are saved, but if an attribute is not +-- customized, its default is saved instead. The file can later be +-- re-loaded as a customization file. +saveTheme :: FilePath -> Theme -> IO () +saveTheme path t = do + let defSection = serializeCustomAttr ["default"] $ + fromMaybe (attrToCustom $ themeDefaultAttr t) (themeCustomDefaultAttr t) + mapSection = concat $ flip map (M.toList $ themeDefaultMapping t) $ \(an, def) -> + serializeCustomAttr (attrNameComponents an) $ + fromMaybe (attrToCustom def) (M.lookup an $ themeCustomMapping t) + content = T.unlines $ (emitSection defaultSectionName defSection) <> + (emitSection otherSectionName mapSection) + T.writeFile path content + +attrToCustom :: Attr -> CustomAttr +attrToCustom a = + CustomAttr { customFg = Just $ attrForeColor a + , customBg = Just $ attrBackColor a + , customStyle = case attrStyle a of + SetTo s -> Just s + _ -> Nothing + } diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -1,5 +1,4 @@ -- | Basic types used by this library. -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Brick.Types @@ -20,34 +19,50 @@ , vpSize , vpTop , vpLeft + , vpContentSize + , VScrollBarOrientation(..) + , HScrollBarOrientation(..) + , VScrollbarRenderer(..) + , HScrollbarRenderer(..) + , ClickableScrollbarElement(..) - -- * Event-handling types + -- * Event-handling types and functions , EventM - , Next - , HandleEvent(..) - , handleEventLensed + , BrickEvent(..) + , nestEventM + , nestEventM' -- * Rendering infrastructure , RenderM , getContext -- ** The rendering context - , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap) + , Context(ctxAttrName, availWidth, availHeight, windowWidth, windowHeight, ctxBorderStyle, ctxAttrMap, ctxDynBorders) , attrL , availWidthL , availHeightL + , windowWidthL + , windowHeightL + , ctxVScrollBarOrientationL + , ctxVScrollBarRendererL + , ctxHScrollBarOrientationL + , ctxHScrollBarRendererL , ctxAttrMapL , ctxAttrNameL , ctxBorderStyleL + , ctxDynBordersL -- ** Rendering results , Result(..) + , emptyResult , lookupAttrName + , Extent(..) -- ** Rendering result lenses , imageL , cursorsL , visibilityRequestsL + , extentsL -- ** Visibility requests , VisibilityRequest(..) @@ -56,127 +71,99 @@ -- * Making lenses , suffixLenses + , suffixLensesWith + -- * Dynamic borders + , bordersL + , DynBorder(..) + , dbStyleL, dbAttrL, dbSegmentsL + , BorderSegment(..) + , bsAcceptL, bsOfferL, bsDrawL + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL + -- * Miscellaneous , Size(..) - , Padding(..) , Direction(..) - , Name(..) + -- * Renderer internals (for benchmarking) + , RenderState + + -- * Re-exports for convenience + , get + , gets + , put + , modify + , zoom ) where -import Control.Lens (_1, _2, to, (^.), (&), (.~), Lens') -import Data.Monoid (Monoid(..)) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader -import Graphics.Vty (Event, Image, emptyImage, Attr) -import Data.Default (Default(..)) -import Data.Functor.Contravariant -import qualified Data.Map as M +import Lens.Micro (_1, _2, to, (^.)) +import Lens.Micro.Type (Getting) +import Lens.Micro.Mtl (zoom) +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif +import Control.Monad.State.Strict +import Control.Monad.Reader +import Graphics.Vty (Attr) import Brick.Types.TH import Brick.Types.Internal +import Brick.Types.EventM import Brick.AttrMap (AttrName, attrMapLookup) --- | The type of padding. -data Padding = Pad Int - -- ^ Pad by the specified number of rows or columns. - | Max - -- ^ Pad up to the number of available rows or columns. - --- | The class of types that provide some basic event-handling. -class HandleEvent a where - -- | Handle a Vty event - handleEvent :: Event -> a -> EventM a - --- | A convenience function for handling events intended for values --- that are targets of lenses in your application state. This function --- obtains the target value of the specified lens, invokes 'handleEvent' --- on it, and stores the resulting transformed value back in the state --- using the lens. -handleEventLensed :: (HandleEvent b) - => a - -- ^ The state value. - -> Lens' a b - -- ^ The lens to use to extract and store the target - -- of the event. - -> Event - -- ^ The event to handle. - -> EventM a -handleEventLensed v target ev = do - newB <- handleEvent ev (v^.target) - return $ v & target .~ newB - --- | The monad in which event handlers run. Although it may be tempting --- to dig into the reader value yourself, just use --- 'Brick.Main.lookupViewport'. -type EventM a = ReaderT (M.Map Name Viewport) (StateT EventState IO) a - --- | Widget growth policies. These policies communicate to layout --- algorithms how a widget uses space when being rendered. These --- policies influence rendering order and space allocation in the box --- layout algorithm. -data Size = Fixed - -- ^ Fixed widgets take up the same amount of space no matter - -- how much they are given (non-greedy). - | Greedy - -- ^ Greedy widgets take up all the space they are given. - deriving (Show, Eq, Ord) - --- | The type of widgets. -data Widget = - Widget { hSize :: Size - -- ^ This widget's horizontal growth policy - , vSize :: Size - -- ^ This widget's vertical growth policy - , render :: RenderM Result - -- ^ This widget's rendering function - } - --- | The type of the rendering monad. This monad is used by the --- library's rendering routines to manage rendering state and --- communicate rendering parameters to widgets' rendering functions. -type RenderM a = ReaderT Context (State RenderState) a - --- | 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. -data Result = - Result { image :: Image - -- ^ The final rendered image for a widget - , cursors :: [CursorLocation] - -- ^ The list of reported cursor positions for the - -- application to choose from - , visibilityRequests :: [VisibilityRequest] - -- ^ The list of visibility requests made by widgets rendered - -- while rendering this one (used by viewports) - } - deriving Show - -instance Default Result where - def = Result emptyImage [] [] +-- | Given a state value and an 'EventM' that mutates that state, run +-- the specified action and return resulting modified state. +nestEventM' :: a + -- ^ The initial state to use in the nested action. + -> EventM n a b + -- ^ The action to run. + -> EventM n s a +nestEventM' s act = fst <$> nestEventM s act --- | Get the current rendering context. -getContext :: RenderM Context -getContext = ask +-- | Given a state value and an 'EventM' that mutates that state, run +-- the specified action and return both the resulting modified state and +-- the result of the action itself. +nestEventM :: a + -- ^ The initial state to use in the nested action. + -> EventM n a b + -- ^ The action to run. + -> EventM n s (a, b) +nestEventM s' act = do + ro <- EventM ask + es <- EventM $ lift $ lift get + vtyCtx <- getVtyContext + let stInner = ES { nextAction = Continue + , esScrollRequests = esScrollRequests es + , cacheInvalidateRequests = cacheInvalidateRequests es + , requestedVisibleNames = requestedVisibleNames es + , vtyContext = vtyCtx + } + ((actResult, newSt), stInnerFinal) <- liftIO $ runStateT (runStateT (runReaderT (runEventM act) ro) s') stInner -suffixLenses ''Context -suffixLenses ''Result + EventM $ lift $ lift $ modify $ + \st -> st { nextAction = nextAction stInnerFinal + , esScrollRequests = esScrollRequests stInnerFinal + , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal + , requestedVisibleNames = requestedVisibleNames stInnerFinal + , vtyContext = vtyContext stInnerFinal + } + return (newSt, actResult) -- | The rendering context's current drawing attribute. -attrL :: (Contravariant f, Functor f) => (Attr -> f Attr) -> Context -> f Context +attrL :: forall r n. Getting r (Context n) Attr attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) -instance TerminalLocation CursorLocation where - columnL = cursorLocationL._1 - column = column . cursorLocation - rowL = cursorLocationL._2 - row = row . cursorLocation +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. -lookupAttrName :: AttrName -> RenderM Attr +lookupAttrName :: AttrName -> RenderM n Attr lookupAttrName n = do c <- getContext return $ attrMapLookup n (c^.ctxAttrMapL) diff --git a/src/Brick/Types/Common.hs b/src/Brick/Types/Common.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Types/Common.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE CPP #-} +module Brick.Types.Common + ( Location(..) + , locL + , origin + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL + ) where + +import Brick.Types.TH (suffixLenses) +import qualified Data.Semigroup as Sem +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) + +suffixLenses ''Location + +instance Field1 Location Location Int Int where + _1 = locL._1 + +instance Field2 Location Location Int Int where + _2 = locL._2 + +-- | The origin (upper-left corner). +origin :: Location +origin = Location (0, 0) + +instance Sem.Semigroup Location where + (Location (w1, h1)) <> (Location (w2, h2)) = Location (w1+w2, h1+h2) + +instance Monoid Location where + mempty = origin + mappend = (Sem.<>) + +data Edges a = Edges { eTop, eBottom, eLeft, eRight :: !a } + deriving (Eq, Ord, Read, Show, Functor, Generic, NFData) + +suffixLenses ''Edges + +instance Applicative Edges where + pure a = Edges a a a a + Edges ft fb fl fr <*> Edges vt vb vl vr = + Edges (ft vt) (fb vb) (fl vl) (fr vr) + +instance Monad Edges where + Edges vt vb vl vr >>= f = Edges + (eTop (f vt)) + (eBottom (f vb)) + (eLeft (f vl)) + (eRight (f vr)) diff --git a/src/Brick/Types/EventM.hs b/src/Brick/Types/EventM.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Types/EventM.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Brick.Types.EventM + ( EventM(..) + , getVtyContext + ) +where + +import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif +import Control.Monad.Reader +import Control.Monad.State.Strict +import Lens.Micro.Mtl +import Lens.Micro.Mtl.Internal + +import Brick.Types.Internal + +-- | The monad in which event handlers run. +newtype EventM n s a = + EventM { runEventM :: ReaderT (EventRO n) (StateT s (StateT (EventState n) IO)) a + } + deriving ( Functor, Applicative, Monad, MonadIO + , MonadThrow, MonadCatch, MonadMask +#if !MIN_VERSION_base(4,13,0) + , MonadFail +#endif + ) + +instance MonadState s (EventM n s) where + get = EventM $ lift get + put = EventM . lift . put + +getVtyContext :: EventM n s VtyContext +getVtyContext = EventM $ lift $ lift $ gets vtyContext + +type instance Zoomed (EventM n s) = Zoomed (StateT s (StateT (EventState n) IO)) + +instance Zoom (EventM n s) (EventM n t) s t where + zoom l (EventM m) = EventM (zoom l m) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} module Brick.Types.Internal ( ScrollRequest(..) , VisibilityRequest(..) , vrPositionL , vrSizeL - , Name(..) , Location(..) , locL , origin @@ -17,150 +19,447 @@ , CursorLocation(..) , cursorLocationL , cursorLocationNameL + , cursorLocationVisibleL + , VScrollBarOrientation(..) + , HScrollBarOrientation(..) + , VScrollbarRenderer(..) + , HScrollbarRenderer(..) + , ClickableScrollbarElement(..) , Context(..) - , EventState - , Next(..) + , ctxAttrMapL + , ctxAttrNameL + , ctxBorderStyleL + , ctxDynBordersL + , ctxVScrollBarOrientationL + , ctxVScrollBarRendererL + , ctxHScrollBarOrientationL + , ctxHScrollBarRendererL + , ctxVScrollBarShowHandlesL + , ctxHScrollBarShowHandlesL + , ctxVScrollBarClickableConstrL + , ctxHScrollBarClickableConstrL + , availWidthL + , availHeightL + , windowWidthL + , windowHeightL - , scrollRequestsL + , Size(..) + + , EventState(..) + , VtyContext(..) + , EventRO(..) + , NextAction(..) + , Result(..) + , Extent(..) + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL + , BorderSegment(..) + , bsAcceptL, bsOfferL, bsDrawL + , DynBorder(..) + , dbStyleL, dbAttrL, dbSegmentsL + , CacheInvalidateRequest(..) + , BrickEvent(..) + , RenderM + , getContext + , lookupReportedExtent + , Widget(..) + + , rsScrollRequestsL , viewportMapL + , clickableNamesL + , reportedExtentsL + , renderCacheL + , observedNamesL + , requestedVisibleNames_L , vpSize , vpLeft , vpTop + , vpContentSize + , imageL + , cursorsL + , extentsL + , bordersL + , visibilityRequestsL + , emptyResult ) where -import Control.Lens (Field1, Field2, _1, _2, Lens', makeLenses) -import Data.String -import Data.Monoid +import Control.Concurrent (ThreadId) +import Control.Monad.Reader +import Control.Monad.State.Strict +import Lens.Micro (_1, _2, Lens') +import Lens.Micro.Mtl (use) +import Lens.Micro.TH (makeLenses) +import qualified Data.Set as S import qualified Data.Map as M -import Graphics.Vty (DisplayRegion) +import Graphics.Vty (Vty, Event, Button, Modifier, DisplayRegion, Image, Attr, emptyImage) +import GHC.Generics +import Control.DeepSeq (NFData) +import Brick.BorderMap (BorderMap) +import qualified Brick.BorderMap as BM +import Brick.Types.Common import Brick.Types.TH import Brick.AttrMap (AttrName, AttrMap) import Brick.Widgets.Border.Style (BorderStyle) --- | Names of things. Used to name cursor locations, widgets, and --- viewports. -newtype Name = Name String - deriving (Eq, Show, Ord) - -instance IsString Name where - fromString = Name - -data RenderState = - RS { viewportMap :: M.Map Name Viewport - , scrollRequests :: [(Name, ScrollRequest)] - } - -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 + deriving (Read, Show, Generic, NFData) +-- | Widget size policies. These policies communicate how a widget uses +-- space when being rendered. These policies influence rendering order +-- and space allocation in the box layout algorithm for 'hBox' and +-- 'vBox'. +data Size = Fixed + -- ^ Widgets advertising this size policy should take up the + -- same amount of space no matter how much they are given, + -- i.e. their size depends on their contents alone rather than + -- on the size of the rendering area. + | Greedy + -- ^ Widgets advertising this size policy must take up all the + -- space they are given. + deriving (Show, Eq, Ord) + +-- | The type of widgets. +data Widget n = + Widget { hSize :: !Size + -- ^ This widget's horizontal growth policy + , vSize :: !Size + -- ^ This widget's vertical growth policy + , render :: RenderM n (Result n) + -- ^ This widget's rendering function + } + +data RenderState n = + RS { viewportMap :: !(M.Map n Viewport) + , rsScrollRequests :: ![(n, ScrollRequest)] + , observedNames :: !(S.Set n) + , renderCache :: !(M.Map n ([n], Result n)) + , clickableNames :: ![n] + , requestedVisibleNames_ :: !(S.Set n) + , reportedExtents :: !(M.Map n (Extent n)) + } deriving (Read, Show, Generic, NFData) + +-- | The type of the rendering monad. This monad is used by the +-- library's rendering routines to manage rendering state and +-- communicate rendering parameters to widgets' rendering functions. +type RenderM n a = ReaderT (Context n) (State (RenderState n)) a + +-- | Get the current rendering context. +getContext :: RenderM n (Context n) +getContext = ask + +-- | Orientations for vertical scroll bars. +data VScrollBarOrientation = OnLeft | OnRight + deriving (Show, Eq) + +-- | Orientations for horizontal scroll bars. +data HScrollBarOrientation = OnBottom | OnTop + deriving (Show, Eq) + +-- | 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 + 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 + -- ^ The size of the contents of the viewport. } - deriving Show + deriving (Show, Read, Generic, NFData) -- | The type of viewports that indicates the direction(s) in which a -- viewport is scrollable. -data ViewportType = Vertical - -- ^ Viewports of this type are scrollable only vertically. - | Horizontal - -- ^ Viewports of this type are scrollable only horizontally. - | Both - -- ^ Viewports of this type are scrollable vertically and horizontally. - deriving Show +data ViewportType = + Vertical + -- ^ Viewports of this type are scrollable only vertically. + | Horizontal + -- ^ Viewports of this type are scrollable only horizontally. + | Both + -- ^ Viewports of this type are scrollable vertically and horizontally. + deriving (Show, Eq) -type EventState = [(Name, ScrollRequest)] +data CacheInvalidateRequest n = + InvalidateSingle n + | InvalidateEntire + deriving (Ord, Eq) +data EventState n = + ES { esScrollRequests :: ![(n, ScrollRequest)] + , cacheInvalidateRequests :: !(S.Set (CacheInvalidateRequest n)) + , requestedVisibleNames :: !(S.Set n) + , nextAction :: !NextAction + , vtyContext :: VtyContext + } + +data VtyContext = + VtyContext { vtyContextBuilder :: !(IO Vty) + , vtyContextHandle :: !Vty + , vtyContextThread :: !ThreadId + , vtyContextPutEvent :: Event -> IO () + } + +-- | An extent of a named area: its size, location, and origin. +data Extent n = Extent { extentName :: !n + , extentUpperLeft :: !Location + , extentSize :: !(Int, Int) + } + deriving (Show, Read, Generic, NFData) + -- | The type of actions to take upon completion of an event handler. -data Next a = Continue a - | SuspendAndResume (IO a) - | Halt a +data NextAction = + Continue + | ContinueWithoutRedraw + | Halt -- | Scrolling direction. data Direction = Up -- ^ Up/left | Down -- ^ Down/right - --- | A terminal screen location. -data Location = Location { loc :: (Int, Int) - -- ^ (Column, Row) - } - deriving Show - -suffixLenses ''Location - -instance Field1 Location Location Int Int where - _1 = locL._1 - -instance Field2 Location Location Int Int where - _2 = locL._2 + deriving (Show, Eq, Read, Generic, NFData) -- | The class of types that behave like terminal locations. class TerminalLocation a where -- | Get the column out of the value - columnL :: Lens' a Int - column :: a -> Int + locationColumnL :: Lens' a Int + locationColumn :: a -> Int + -- | Get the row out of the value - rowL :: Lens' a Int - row :: a -> Int + locationRowL :: Lens' a Int + locationRow :: a -> Int instance TerminalLocation Location where - columnL = _1 - column (Location t) = fst t - rowL = _2 - row (Location t) = snd t - --- | The origin (upper-left corner). -origin :: Location -origin = Location (0, 0) - -instance Monoid Location where - mempty = origin - mappend (Location (w1, h1)) (Location (w2, h2)) = Location (w1+w2, h1+h2) + locationColumnL = _1 + locationColumn (Location t) = fst t + locationRowL = _2 + locationRow (Location t) = snd t -- | A cursor location. These are returned by the rendering process. -data CursorLocation = +data CursorLocation n = CursorLocation { cursorLocation :: !Location -- ^ The location - , cursorLocationName :: !(Maybe Name) + , cursorLocationName :: !(Maybe n) -- ^ The name of the widget associated with the location + , cursorLocationVisible :: !Bool + -- ^ Whether the cursor should actually be visible } - deriving Show + deriving (Read, Show, Generic, NFData) +-- | 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 + -- ^ Would this segment be willing to be drawn if a neighbor wanted to + -- connect to it? + , bsOffer :: !Bool + -- ^ Does this segment want to connect to its neighbor? + , 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 + -- ^ 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 + -- ^ 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) + } deriving (Eq, Read, Show, 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. +data Result n = + Result { image :: !Image + -- ^ The final rendered image for a widget + , cursors :: ![CursorLocation n] + -- ^ The list of reported cursor positions for the + -- application to choose from + , visibilityRequests :: ![VisibilityRequest] + -- ^ The list of visibility requests made by widgets rendered + -- while rendering this one (used by viewports) + , extents :: ![Extent n] + -- Programmer's note: we don't try to maintain the invariant that + -- the size of the borders closely matches the size of the 'image' + -- field. Most widgets don't need to care about borders, and so they + -- use the empty 'BorderMap' that has a degenerate rectangle. Only + -- border-drawing widgets and the hbox/vbox stuff try to set this + -- carefully. Even then, in the boxes, we only make sure that the + -- 'BorderMap' is no larger than the entire concatenation of boxes, + -- and it's certainly possible for it to be smaller. (Resizing + -- 'BorderMap's is lossy, so we try to do it as little as possible.) + -- If you're writing a widget, this should make it easier for you to + -- do so; but beware this lack of invariant if you are consuming + -- widgets. + , borders :: !(BorderMap DynBorder) + -- ^ Places where we may rewrite the edge of the image when + -- placing this widget next to another one. + } + deriving (Show, Read, Generic, NFData) + +emptyResult :: Result n +emptyResult = + Result { image = emptyImage + , cursors = [] + , visibilityRequests = [] + , extents = [] + , borders = BM.empty + } + +-- | The type of events. +data BrickEvent n e = VtyEvent !Event + -- ^ The event was a Vty event. + | AppEvent !e + -- ^ The event was an application event. + | 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 + -- ^ 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) + } + +-- | Clickable elements of a scroll bar. +data ClickableScrollbarElement = + SBHandleBefore + -- ^ The handle at the beginning (left/top) of the scroll bar. + | SBHandleAfter + -- ^ The handle at the end (right/bottom) of the scroll bar. + | SBBar + -- ^ The scroll bar itself. + | SBTroughBefore + -- ^ The trough before the scroll bar. + | SBTroughAfter + -- ^ The trough after the scroll bar. + deriving (Eq, Show, Ord) + -- | The rendering context. This tells widgets how to render: how much -- space they have in which to render, which attribute they should use --- to render, which bordring style should be used, and the attribute map +-- to render, which bordering style should be used, and the attribute map -- available for rendering. -data Context = - Context { ctxAttrName :: AttrName - , availWidth :: Int - , availHeight :: Int - , ctxBorderStyle :: BorderStyle - , ctxAttrMap :: AttrMap +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 (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 suffixLenses ''VisibilityRequest suffixLenses ''CursorLocation +suffixLenses ''Context +suffixLenses ''DynBorder +suffixLenses ''Result +suffixLenses ''BorderSegment makeLenses ''Viewport + +lookupReportedExtent :: (Ord n) => n -> RenderM n (Maybe (Extent n)) +lookupReportedExtent n = do + m <- lift $ use reportedExtentsL + return $ M.lookup n m diff --git a/src/Brick/Types/TH.hs b/src/Brick/Types/TH.hs --- a/src/Brick/Types/TH.hs +++ b/src/Brick/Types/TH.hs @@ -1,18 +1,25 @@ module Brick.Types.TH ( suffixLenses + , suffixLensesWith ) where import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Lib as TH -import Control.Lens (DefName(..), makeLensesWith, lensRules, (&), (.~), lensField) +import Lens.Micro ((&), (.~)) +import Lens.Micro.TH (DefName(..), LensRules, makeLensesWith, lensRules, lensField) -- | A template haskell function to build lenses for a record type. This --- function differs from the 'Control.Lens.makeLenses' function in that +-- function differs from the 'Lens.Micro.TH.makeLenses' function in that -- it does not require the record fields to be prefixed with underscores -- and it adds an "L" suffix to lens names to make it clear that they -- are lenses. suffixLenses :: TH.Name -> TH.DecsQ -suffixLenses = makeLensesWith $ - lensRules & lensField .~ (\_ _ name -> [TopName $ TH.mkName $ TH.nameBase name ++ "L"]) +suffixLenses = suffixLensesWith "L" lensRules + +-- | A more general version of 'suffixLenses' that allows customization +-- of the lens-building rules and allows customization of the suffix. +suffixLensesWith :: String -> LensRules -> TH.Name -> TH.DecsQ +suffixLensesWith suffix rs = makeLensesWith $ + rs & lensField .~ (\_ _ name -> [TopName $ TH.mkName $ TH.nameBase name ++ suffix]) diff --git a/src/Brick/Util.hs b/src/Brick/Util.hs --- a/src/Brick/Util.hs +++ b/src/Brick/Util.hs @@ -4,12 +4,15 @@ , on , fg , bg + , style , clOffset ) where -import Control.Lens ((&), (%~)) +import Lens.Micro ((&), (%~)) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) +#endif import Graphics.Vty import Brick.Types.Internal (Location(..), CursorLocation(..), cursorLocationL) @@ -50,10 +53,15 @@ 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`) +-- | Create an attribute from the specified style (the colors are the +-- "default"). +style :: Style -> Attr +style = (defAttr `withStyle`) + -- | Add a 'Location' offset to the specified 'CursorLocation'. -clOffset :: CursorLocation -> Location -> CursorLocation +clOffset :: CursorLocation n -> Location -> CursorLocation n clOffset cl off = cl & cursorLocationL %~ (<> off) diff --git a/src/Brick/Widgets/Border.hs b/src/Brick/Widgets/Border.hs --- a/src/Brick/Widgets/Border.hs +++ b/src/Brick/Widgets/Border.hs @@ -18,98 +18,89 @@ -- * Drawing single border elements , borderElem - -- * Border attribute names + -- * Attribute names , borderAttr - , vBorderAttr , hBorderAttr - , hBorderLabelAttr - , tlCornerAttr - , trCornerAttr - , blCornerAttr - , brCornerAttr + , vBorderAttr + + -- * Utility + , joinableBorder ) where -import Control.Applicative ((<$>)) -import Control.Lens ((^.), to) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) +#endif +import Lens.Micro ((^.), (&), (.~), to) import Graphics.Vty (imageHeight, imageWidth) import Brick.AttrMap import Brick.Types import Brick.Widgets.Core -import Brick.Widgets.Center (hCenterWith) import Brick.Widgets.Border.Style (BorderStyle(..)) +import Brick.Widgets.Internal (renderDynBorder) +import Data.IMap (Run(..)) +import qualified Brick.BorderMap as BM -- | The top-level border attribute name. borderAttr :: AttrName -borderAttr = "border" - --- | The vertical border attribute name. -vBorderAttr :: AttrName -vBorderAttr = borderAttr <> "vertical" +borderAttr = attrName "border" --- | The horizontal border attribute name. +-- | The horizontal border attribute name. Inherits from 'borderAttr'. hBorderAttr :: AttrName -hBorderAttr = borderAttr <> "horizontal" - --- | The attribute used for horizontal border labels. -hBorderLabelAttr :: AttrName -hBorderLabelAttr = hBorderAttr <> "label" - --- | The attribute used for border box top-left corners. -tlCornerAttr :: AttrName -tlCornerAttr = borderAttr <> "corner" <> "tl" - --- | The attribute used for border box top-right corners. -trCornerAttr :: AttrName -trCornerAttr = borderAttr <> "corner" <> "tr" - --- | The attribute used for border box bottom-left corners. -blCornerAttr :: AttrName -blCornerAttr = borderAttr <> "corner" <> "bl" +hBorderAttr = borderAttr <> attrName "horizontal" --- | The attribute used for border box bottom-right corners. -brCornerAttr :: AttrName -brCornerAttr = borderAttr <> "corner" <> "br" +-- | The vertical border attribute name. Inherits from 'borderAttr'. +vBorderAttr :: AttrName +vBorderAttr = borderAttr <> attrName "vertical" -- | Draw the specified border element using the active border style -- using 'borderAttr'. -borderElem :: (BorderStyle -> Char) -> Widget +-- +-- Does not participate in dynamic borders (due to the difficulty of +-- introspecting on the first argument); consider using 'joinableBorder' +-- instead. +borderElem :: (BorderStyle -> Char) -> Widget n borderElem f = Widget Fixed Fixed $ do bs <- ctxBorderStyle <$> getContext render $ withAttr borderAttr $ str [f bs] -- | Put a border around the specified widget. -border :: Widget -> Widget +border :: Widget n -> Widget n border = border_ Nothing -- | Put a border around the specified widget with the specified label -- widget placed in the middle of the top horizontal border. -borderWithLabel :: Widget +-- +-- Note that a border will wrap its child widget as tightly as possible, +-- which means that if the child widget is narrower than the label +-- widget, the label widget will be truncated. If you want to avoid +-- this behavior, add a 'fill' or other space-filling wrapper to the +-- bordered widget so that it takes up enough room to make the border +-- horizontally able to avoid truncating the label. +borderWithLabel :: Widget n -- ^ The label widget - -> Widget + -> Widget n -- ^ The widget to put a border around - -> Widget + -> Widget n borderWithLabel label = border_ (Just label) -border_ :: Maybe Widget -> Widget -> Widget +border_ :: Maybe (Widget n) -> Widget n -> Widget n border_ label wrapped = Widget (hSize wrapped) (vSize wrapped) $ do - bs <- ctxBorderStyle <$> getContext c <- getContext middleResult <- render $ hLimit (c^.availWidthL - 2) $ vLimit (c^.availHeightL - 2) $ wrapped - let top = (withAttr tlCornerAttr $ str [bsCornerTL bs]) - <+> hBorder_ label <+> - (withAttr trCornerAttr $ str [bsCornerTR bs]) - bottom = (withAttr blCornerAttr $ str [bsCornerBL bs]) - <+> hBorder <+> - (withAttr brCornerAttr $ str [bsCornerBR bs]) + let tl = joinableBorder (Edges False True False True) + tr = joinableBorder (Edges False True True False) + bl = joinableBorder (Edges True False False True) + br = joinableBorder (Edges True False True False) + top = tl <+> maybe hBorder hBorderWithLabel label <+> tr + bottom = bl <+> hBorder <+> br middle = vBorder <+> (Widget Fixed Fixed $ return middleResult) <+> vBorder total = top <=> middle <=> bottom @@ -117,27 +108,76 @@ $ vLimit (middleResult^.imageL.to imageHeight + 2) $ total --- | A horizontal border. Fills all horizontal space. -hBorder :: Widget -hBorder = hBorder_ Nothing +-- | A horizontal border. Fills all horizontal space. Draws using +-- 'hBorderAttr'. +hBorder :: Widget n +hBorder = + withAttr borderAttr $ Widget Greedy Fixed $ do + ctx <- getContext + let bs = ctxBorderStyle ctx + w = availWidth ctx + db <- dynBorderFromDirections (Edges False False True True) + let dynBorders = BM.insertH mempty (Run w db) + $ BM.emptyCoordinates (Edges 0 0 0 (w-1)) + setDynBorders dynBorders $ render $ withAttr hBorderAttr + $ vLimit 1 $ fill (bsHorizontal bs) -- | A horizontal border with a label placed in the center of the -- border. Fills all horizontal space. -hBorderWithLabel :: Widget +hBorderWithLabel :: Widget n -- ^ The label widget - -> Widget -hBorderWithLabel label = hBorder_ (Just label) - -hBorder_ :: Maybe Widget -> Widget -hBorder_ label = + -> Widget n +hBorderWithLabel label = Widget Greedy Fixed $ do - bs <- ctxBorderStyle <$> getContext - let msg = maybe (str [bsHorizontal bs]) (withAttr hBorderLabelAttr) label - render $ vLimit 1 $ withAttr hBorderAttr $ hCenterWith (Just $ bsHorizontal bs) msg + res <- render $ vLimit 1 label + render $ hBox [hBorder, Widget Fixed Fixed (return res), hBorder] --- | A vertical border. Fills all vertical space. -vBorder :: Widget +-- | A vertical border. Fills all vertical space. Draws using +-- 'vBorderAttr'. +vBorder :: Widget n vBorder = - Widget Fixed Greedy $ do - bs <- ctxBorderStyle <$> getContext - render $ hLimit 1 $ withAttr vBorderAttr $ fill (bsVertical bs) + withAttr borderAttr $ Widget Fixed Greedy $ do + ctx <- getContext + let bs = ctxBorderStyle ctx + h = availHeight ctx + db <- dynBorderFromDirections (Edges True True False False) + let dynBorders = BM.insertV mempty (Run h db) + $ BM.emptyCoordinates (Edges 0 (h-1) 0 0) + setDynBorders dynBorders $ render $ withAttr vBorderAttr + $ hLimit 1 $ fill (bsVertical bs) + +-- | Initialize a 'DynBorder'. It will be 'bsDraw'n and 'bsOffer'ing +-- in the given directions to begin with, and accept join offers from +-- all directions. We consult the context to choose the 'dbStyle' and +-- 'dbAttr'. +-- +-- This is likely to be useful only for custom widgets that need more +-- complicated dynamic border behavior than 'border', 'vBorder', or +-- 'hBorder' offer. +dynBorderFromDirections :: Edges Bool -> RenderM n DynBorder +dynBorderFromDirections dirs = do + ctx <- getContext + return DynBorder + { dbStyle = ctxBorderStyle ctx + , dbAttr = attrMapLookup (ctxAttrName ctx) (ctxAttrMap ctx) + , dbSegments = (\draw -> BorderSegment True draw draw) <$> dirs + } + +-- | Replace the 'Result'\'s dynamic borders with the given one, +-- provided the context says to use dynamic borders at all. +setDynBorders :: BM.BorderMap DynBorder -> RenderM n (Result n) -> RenderM n (Result n) +setDynBorders newBorders act = do + dyn <- ctxDynBorders <$> getContext + res <- act + return $ if dyn + then res & bordersL .~ newBorders + else res + +-- | A single-character dynamic border that will react to neighboring +-- borders, initially connecting in the given directions. +joinableBorder :: Edges Bool -> Widget n +joinableBorder dirs = withAttr borderAttr . Widget Fixed Fixed $ do + db <- dynBorderFromDirections dirs + setDynBorders + (BM.singleton mempty db) + (render (raw (renderDynBorder db))) diff --git a/src/Brick/Widgets/Border/Style.hs b/src/Brick/Widgets/Border/Style.hs --- a/src/Brick/Widgets/Border/Style.hs +++ b/src/Brick/Widgets/Border/Style.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} -- | This module provides styles for borders as used in terminal -- applications. Your mileage may vary on some of the fancier styles -- due to varying support for some border characters in the fonts your @@ -8,8 +9,7 @@ -- -- To use these in your widgets, see -- 'Brick.Widgets.Core.withBorderStyle'. By default, widgets rendered --- without a specified border style use 'unicode' via the 'Default' --- instance provided by 'BorderStyle'. +-- without a specified border style use 'unicode' style. module Brick.Widgets.Border.Style ( BorderStyle(..) , borderStyleFromChar @@ -17,10 +17,12 @@ , unicode , unicodeBold , unicodeRounded + , defaultBorderStyle ) where -import Data.Default +import GHC.Generics +import Control.DeepSeq -- | A border style for use in any widget that needs to render borders -- in a consistent style. @@ -48,10 +50,10 @@ , bsVertical :: Char -- ^ Vertical border character } - deriving (Show, Read) + deriving (Show, Read, Eq, Generic, NFData) -instance Default BorderStyle where - def = unicode +defaultBorderStyle :: BorderStyle +defaultBorderStyle = unicode -- | Make a border style using the specified character everywhere. borderStyleFromChar :: Char -> BorderStyle diff --git a/src/Brick/Widgets/Center.hs b/src/Brick/Widgets/Center.hs --- a/src/Brick/Widgets/Center.hs +++ b/src/Brick/Widgets/Center.hs @@ -3,42 +3,66 @@ ( -- * Centering horizontally hCenter , hCenterWith + , hCenterLayer -- * Centering vertically , vCenter , vCenterWith + , vCenterLayer -- * Centering both horizontally and vertically , center , centerWith + , centerLayer -- * Centering about an arbitrary origin , centerAbout ) where -import Control.Lens ((^.), (&), (.~), to) -import Graphics.Vty (imageWidth, imageHeight, horizCat, charFill, vertCat) +import Lens.Micro ((^.), (&), (.~), to) +import Data.Maybe (fromMaybe) +import Graphics.Vty (imageWidth, imageHeight, horizCat, charFill, vertCat, + translateX, translateY) import Brick.Types import Brick.Widgets.Core -- | Center the specified widget horizontally. Consumes all available -- horizontal space. -hCenter :: Widget -> Widget +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. +hCenterLayer :: Widget n -> Widget n +hCenterLayer p = + Widget Greedy (vSize p) $ do + result <- render p + 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 + -- | Center the specified widget horizontally. Consumes all available -- horizontal space. Uses the specified character to fill in the space -- to either side of the centered widget (defaults to space). -hCenterWith :: Maybe Char -> Widget -> Widget +hCenterWith :: Maybe Char -> Widget n -> Widget n hCenterWith mChar p = - let ch = maybe ' ' id mChar + let ch = fromMaybe ' ' mChar in Widget Greedy (vSize p) $ do result <- render p c <- getContext let rWidth = result^.imageL.to imageWidth rHeight = result^.imageL.to imageHeight - remainder = c^.availWidthL - (leftPaddingAmount * 2) - leftPaddingAmount = (c^.availWidthL - rWidth) `div` 2 - rightPaddingAmount = leftPaddingAmount + remainder + 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 rightPadding = charFill (c^.attrL) ch rightPaddingAmount rHeight paddedImage = horizCat [ leftPadding @@ -52,23 +76,42 @@ $ result & imageL .~ paddedImage -- | Center a widget vertically. Consumes all vertical space. -vCenter :: Widget -> Widget +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. +vCenterLayer :: Widget n -> Widget n +vCenterLayer p = + Widget (hSize p) Greedy $ do + result <- render p + 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 + -- | Center a widget vertically. Consumes all vertical space. Uses the -- specified character to fill in the space above and below the centered -- widget (defaults to space). -vCenterWith :: Maybe Char -> Widget -> Widget +vCenterWith :: Maybe Char -> Widget n -> Widget n vCenterWith mChar p = - let ch = maybe ' ' id mChar + let ch = fromMaybe ' ' mChar in Widget (hSize p) Greedy $ do result <- render p c <- getContext let rWidth = result^.imageL.to imageWidth rHeight = result^.imageL.to imageHeight - remainder = c^.availHeightL - (topPaddingAmount * 2) - topPaddingAmount = (c^.availHeightL - rHeight) `div` 2 - bottomPaddingAmount = topPaddingAmount + remainder + remainder = max 0 $ c^.availHeightL - (topPaddingAmount * 2) + topPaddingAmount = max 0 $ (c^.availHeightL - rHeight) `div` 2 + bottomPaddingAmount = max 0 $ topPaddingAmount + remainder topPadding = charFill (c^.attrL) ch rWidth topPaddingAmount bottomPadding = charFill (c^.attrL) ch rWidth bottomPaddingAmount paddedImage = vertCat [ topPadding @@ -83,18 +126,26 @@ -- | Center a widget both vertically and horizontally. Consumes all -- available vertical and horizontal space. -center :: Widget -> Widget +center :: Widget n -> Widget n center = centerWith Nothing -- | Center a widget both vertically and horizontally. Consumes all -- available vertical and horizontal space. Uses the specified character -- to fill in the space around the centered widget (defaults to space). -centerWith :: Maybe Char -> Widget -> Widget +centerWith :: Maybe Char -> Widget n -> Widget n centerWith c = vCenterWith c . hCenterWith c +-- | Center a widget both vertically and horizontally using a Vty image +-- 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 +-- will be visible in the region surrounding the centered widget. +centerLayer :: Widget n -> Widget n +centerLayer = vCenterLayer . hCenterLayer + -- | Center the widget horizontally and vertically about the specified -- origin. -centerAbout :: Location -> Widget -> Widget +centerAbout :: Location -> Widget n -> Widget n centerAbout l p = Widget Greedy Greedy $ do -- Compute translation offset so that loc is in the middle of the @@ -102,7 +153,16 @@ c <- getContext let centerW = c^.availWidthL `div` 2 centerH = c^.availHeightL `div` 2 - off = Location ( centerW - l^.columnL - , centerH - l^.rowL + off = Location ( centerW - l^.locationColumnL + , centerH - l^.locationRowL ) - render $ translateBy off p + result <- render $ translateBy off p + + -- Pad the result so it consumes available space + let rightPaddingAmt = max 0 $ c^.availWidthL - imageWidth (result^.imageL) + bottomPaddingAmt = max 0 $ c^.availHeightL - imageHeight (result^.imageL) + rightPadding = charFill (c^.attrL) ' ' rightPaddingAmt (imageHeight $ result^.imageL) + bottomPadding = charFill (c^.attrL) ' ' (imageWidth $ result^.imageL) bottomPaddingAmt + paddedImg = horizCat [vertCat [result^.imageL, bottomPadding], rightPadding] + + return $ result & imageL .~ paddedImg diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -1,741 +1,1986 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} --- | This module provides the core widget combinators and rendering --- routines. Everything this library does is in terms of these basic --- primitives. -module Brick.Widgets.Core - ( -- * Basic rendering primitives - emptyWidget - , raw - , txt - , str - , fill - - -- * Padding - , padLeft - , padRight - , padTop - , padBottom - , padLeftRight - , padTopBottom - , padAll - - -- * Box layout - , (<=>) - , (<+>) - , hBox - , vBox - - -- * Limits - , hLimit - , vLimit - - -- * Attribute mangement - , withDefAttr - , withAttr - , forceAttr - , updateAttrMap - - -- * Border style management - , withBorderStyle - - -- * Cursor placement - , showCursor - - -- * Translation - , translateBy - - -- * Cropping - , cropLeftBy - , cropRightBy - , cropTopBy - , cropBottomBy - - -- * Scrollable viewports - , viewport - , visible - , visibleRegion - - -- ** Adding offsets to cursor positions and visibility requests - , addResultOffset - - -- ** Cropping results - , cropToContext - ) -where - -import Control.Applicative -import Control.Lens ((^.), (.~), (&), (%~), to, _1, _2, each, to, ix) -import Control.Monad (when) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class (lift) -import qualified Data.Text as T -import Data.Default -import Data.Monoid ((<>), mempty) -import qualified Data.Map as M -import qualified Data.Function as DF -import Data.List (sortBy, partition) -import Control.Lens (Lens') -import qualified Graphics.Vty as V -import Control.DeepSeq - -import Brick.Types -import Brick.Types.Internal -import Brick.Widgets.Border.Style -import Brick.Util (clOffset, clamp) -import Brick.AttrMap -import Brick.Widgets.Internal - --- | When rendering the specified widget, use the specified border style --- for any border rendering. -withBorderStyle :: BorderStyle -> Widget -> Widget -withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p) - --- | The empty widget. -emptyWidget :: Widget -emptyWidget = raw V.emptyImage - --- | Add an offset to all cursor locations and visbility requests --- 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 -> Result -addResultOffset off = addCursorOffset off . addVisibilityOffset off - -addVisibilityOffset :: Location -> Result -> Result -addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>) - -addCursorOffset :: Location -> Result -> Result -addCursorOffset off r = - let onlyVisible = filter isVisible - isVisible l = l^.columnL >= 0 && l^.rowL >= 0 - in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs) - -unrestricted :: Int -unrestricted = 100000 - --- | Build a widget from a 'String'. Breaks newlines up and space-pads --- short lines out to the length of the longest line. -str :: String -> Widget -str s = - Widget Fixed Fixed $ do - c <- getContext - let theLines = fixEmpty <$> (dropUnused . lines) s - fixEmpty [] = " " - fixEmpty l = l - dropUnused l = take (availWidth c) <$> take (availHeight c) l - case force theLines of - [] -> return def - [one] -> return $ def & imageL .~ (V.string (c^.attrL) one) - multiple -> - let maxLength = maximum $ length <$> multiple - lineImgs = lineImg <$> multiple - lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - length lStr) ' ') - in return $ def & imageL .~ (V.vertCat lineImgs) - --- | Build a widget from a one-line 'T.Text' value. Behaves the same as --- 'str'. -txt :: T.Text -> Widget -txt = str . T.unpack - --- | Pad the specified widget on the left. If max padding is used, this --- grows greedily horizontally; otherwise it defers to the padded --- widget. -padLeft :: Padding -> Widget -> Widget -padLeft padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (hLimit i, hSize p) - in Widget sz (vSize p) $ do - result <- render p - render $ (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') <+> - (Widget Fixed Fixed $ return result) - --- | Pad the specified widget on the right. If max padding is used, --- this grows greedily horizontally; otherwise it defers to the padded --- widget. -padRight :: Padding -> Widget -> Widget -padRight padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (hLimit i, hSize p) - in Widget sz (vSize p) $ do - result <- render p - render $ (Widget Fixed Fixed $ return result) <+> - (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') - --- | Pad the specified widget on the top. If max padding is used, this --- grows greedily vertically; otherwise it defers to the padded widget. -padTop :: Padding -> Widget -> Widget -padTop padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (vLimit i, vSize p) - in Widget (hSize p) sz $ do - result <- render p - render $ (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') <=> - (Widget Fixed Fixed $ return result) - --- | Pad the specified widget on the bottom. If max padding is used, --- this grows greedily vertically; otherwise it defers to the padded --- widget. -padBottom :: Padding -> Widget -> Widget -padBottom padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (vLimit i, vSize p) - in Widget (hSize p) sz $ do - result <- render p - render $ (Widget Fixed Fixed $ return result) <=> - (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') - --- | Pad a widget on the left and right. Defers to the padded widget for --- growth policy. -padLeftRight :: Int -> Widget -> Widget -padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w - --- | Pad a widget on the top and bottom. Defers to the padded widget for --- growth policy. -padTopBottom :: Int -> Widget -> Widget -padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w - --- | Pad a widget on all sides. Defers to the padded widget for growth --- policy. -padAll :: Int -> Widget -> Widget -padAll v w = padLeftRight v $ padTopBottom v w - --- | Fill all available space with the specified character. Grows both --- horizontally and vertically. -fill :: Char -> Widget -fill ch = - Widget Greedy Greedy $ do - c <- getContext - return $ def & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL)) - --- | Vertical box layout: put the specified widgets one above the other --- 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). -vBox :: [Widget] -> Widget -vBox [] = emptyWidget -vBox pairs = renderBox vBoxRenderer pairs - --- | Horizontal box layout: put the specified widgets next to each other --- 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). -hBox :: [Widget] -> Widget -hBox [] = emptyWidget -hBox pairs = renderBox hBoxRenderer pairs - --- | The process of rendering widgets in a box layout is exactly the --- same except for the dimension under consideration (width vs. height), --- in which case all of the same operations that consider one dimension --- in the layout algorithm need to be switched to consider the other. --- Because of this we fill a BoxRenderer with all of the functions --- needed to consider the "primary" dimension (e.g. vertical if the --- box layout is vertical) as well as the "secondary" dimension (e.g. --- horizontal if the box layout is vertical). Doing this permits us to --- have one implementation for box layout and parameterizing on the --- orientation of all of the operations. -data BoxRenderer = - BoxRenderer { contextPrimary :: Lens' Context Int - , contextSecondary :: Lens' Context Int - , imagePrimary :: V.Image -> Int - , imageSecondary :: V.Image -> Int - , limitPrimary :: Int -> Widget -> Widget - , limitSecondary :: Int -> Widget -> Widget - , primaryWidgetSize :: Widget -> Size - , concatenatePrimary :: [V.Image] -> V.Image - , locationFromOffset :: Int -> Location - , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image - } - -vBoxRenderer :: BoxRenderer -vBoxRenderer = - BoxRenderer { contextPrimary = availHeightL - , contextSecondary = availWidthL - , imagePrimary = V.imageHeight - , imageSecondary = V.imageWidth - , limitPrimary = vLimit - , limitSecondary = hLimit - , primaryWidgetSize = vSize - , concatenatePrimary = V.vertCat - , locationFromOffset = Location . (0 ,) - , padImageSecondary = \amt img a -> - let p = V.charFill a ' ' amt (V.imageHeight img) - in V.horizCat [img, p] - } - -hBoxRenderer :: BoxRenderer -hBoxRenderer = - BoxRenderer { contextPrimary = availWidthL - , contextSecondary = availHeightL - , imagePrimary = V.imageWidth - , imageSecondary = V.imageHeight - , limitPrimary = hLimit - , limitSecondary = vLimit - , primaryWidgetSize = hSize - , concatenatePrimary = V.horizCat - , locationFromOffset = Location . (, 0) - , padImageSecondary = \amt img a -> - let p = V.charFill a ' ' (V.imageWidth img) amt - in V.vertCat [img, p] - } - --- | Render a series of widgets in a box layout in the order given. --- --- The growth policy of a box layout is the most unrestricted of the --- growth policies of the widgets it contains, so to determine the hSize --- and vSize of the box we just take the maximum (using the Ord instance --- for Size) of all of the widgets to be rendered in the box. --- --- Then the box layout algorithm proceeds as follows. We'll use --- the vertical case to concretely describe the algorithm, but the --- horizontal case can be envisioned just by exchanging all --- "vertical"/"horizontal" and "rows"/"columns", etc., in the --- description. --- --- The growth policies of the child widgets determine the order in which --- they are rendered, i.e., the order in which space in the box is --- allocated to widgets as the algorithm proceeds. This is because order --- matters: if we render greedy widgets first, there will be no space --- left for non-greedy ones. --- --- So we render all widgets with size 'Fixed' in the vertical dimension --- first. Each is rendered with as much room as the overall box has, but --- we assume that they will not be greedy and use it all. If they do, --- maybe it's because the terminal is small and there just isn't enough --- room to render everything. --- --- Then the remaining height is distributed evenly amongst all remaining --- (greedy) widgets and they are rendered in sub-boxes that are as high --- as this even slice of rows and as wide as the box is permitted to be. --- We only do this step at all if rendering the non-greedy widgets left --- us any space, i.e., if there were any rows left. --- --- After rendering the non-greedy and then greedy widgets, their images --- are sorted so that they are stored in the order the original widgets --- were given. All cursor locations and visibility requests in each --- sub-widget are translated according to the position of the sub-widget --- in the box. --- --- All images are padded to be as wide as the widest sub-widget to --- prevent attribute over-runs. Without this step the attribute used by --- a sub-widget may continue on in an undesirable fashion until it hits --- something with a different attribute. To prevent this and to behave --- in the least surprising way, we pad the image on the right with --- whitespace using the context's current attribute. --- --- Finally, the padded images are concatenated together vertically and --- returned along with the translated cursor positions and visibility --- requests. -renderBox :: BoxRenderer -> [Widget] -> Widget -renderBox br ws = do - Widget (maximum $ hSize <$> ws) (maximum $ vSize <$> ws) $ do - c <- getContext - - let pairsIndexed = zip [(0::Int)..] ws - (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed) pairsIndexed - - renderedHis <- mapM (\(i, prim) -> (i,) <$> render prim) his - - renderedLows <- case lows of - [] -> return [] - ls -> do - let remainingPrimary = c^.(contextPrimary br) - (sum $ (^._2.imageL.(to $ imagePrimary br)) <$> renderedHis) - primaryPerLow = remainingPrimary `div` length ls - padFirst = remainingPrimary - (primaryPerLow * length ls) - secondaryPerLow = c^.(contextSecondary br) - primaries = replicate (length ls) primaryPerLow & ix 0 %~ (+ padFirst) - - let renderLow ((i, prim), pri) = - (i,) <$> (render $ limitPrimary br pri - $ limitSecondary br secondaryPerLow - $ cropToContext prim) - - if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return [] - - let rendered = sortBy (compare `DF.on` fst) $ renderedHis ++ renderedLows - allResults = snd <$> rendered - allImages = (^.imageL) <$> allResults - allPrimaries = imagePrimary br <$> allImages - allTranslatedResults = (flip map) (zip [0..] allResults) $ \(i, result) -> - let off = locationFromOffset br offPrimary - offPrimary = sum $ take i allPrimaries - in addResultOffset off result - -- Determine the secondary dimension value to pad to. In a - -- vertical box we want all images to be the same width to - -- avoid attribute over-runs or blank spaces with the wrong - -- attribute. In a horizontal box we want all images to have - -- the same height for the same reason. - maxSecondary = maximum $ imageSecondary br <$> allImages - padImage img = padImageSecondary br (maxSecondary - imageSecondary br img) img (c^.attrL) - paddedImages = padImage <$> allImages - - cropResultToContext $ Result (concatenatePrimary br paddedImages) - (concat $ cursors <$> allTranslatedResults) - (concat $ visibilityRequests <$> allTranslatedResults) - --- | Limit the space available to the specified widget to the specified --- number of columns. This is important for constraining the horizontal --- growth of otherwise-greedy widgets. This is non-greedy horizontally --- and defers to the limited widget vertically. -hLimit :: Int -> Widget -> Widget -hLimit w p = - Widget Fixed (vSize p) $ do - withReaderT (& availWidthL .~ w) $ 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 -> Widget -vLimit h p = - Widget (hSize p) Fixed $ do - withReaderT (& availHeightL .~ h) $ render $ cropToContext p - --- | When drawing the specified widget, set the current attribute used --- for drawing to the one with the specified name. Note that the widget --- may use further calls to 'withAttr' to override this; if you really --- want to prevent that, use 'forceAttr'. Attributes used this way still --- get merged hierarchically and still fall back to the attribute map's --- default attribute. If you want to change the default attribute, use --- 'withDefAttr'. -withAttr :: AttrName -> Widget -> Widget -withAttr an p = - Widget (hSize p) (vSize p) $ do - withReaderT (& ctxAttrNameL .~ an) (render p) - --- | Update the attribute map while rendering the specified widget: set --- its new default attribute to the one that we get by looking up the --- specified attribute name in the map. -withDefAttr :: AttrName -> Widget -> Widget -withDefAttr an p = - Widget (hSize p) (vSize p) $ do - c <- getContext - withReaderT (& ctxAttrMapL %~ (setDefault (attrMapLookup an (c^.ctxAttrMapL)))) (render p) - --- | When rendering the specified widget, update the attribute map with --- the specified transformation. -updateAttrMap :: (AttrMap -> AttrMap) -> Widget -> Widget -updateAttrMap f p = - Widget (hSize p) (vSize p) $ do - withReaderT (& ctxAttrMapL %~ f) (render p) - --- | When rendering the specified widget, force all attribute lookups --- in the attribute map to use the value currently assigned to the --- specified attribute name. -forceAttr :: AttrName -> Widget -> Widget -forceAttr an p = - Widget (hSize p) (vSize p) $ do - c <- getContext - withReaderT (& ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p) - --- | Build a widget directly from a raw Vty image. -raw :: V.Image -> Widget -raw img = Widget Fixed Fixed $ return $ def & imageL .~ img - --- | Translate the specified widget by the specified offset amount. --- Defers to the translated width for growth policy. -translateBy :: Location -> Widget -> Widget -translateBy off p = - Widget (hSize p) (vSize p) $ do - result <- render p - return $ addResultOffset off - $ result & imageL %~ (V.translate (off^.columnL) (off^.rowL)) - --- | Crop the specified widget on the left by the specified number of --- columns. Defers to the translated width for growth policy. -cropLeftBy :: Int -> Widget -> Widget -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 - --- | Crop the specified widget on the right by the specified number of --- columns. Defers to the translated width for growth policy. -cropRightBy :: Int -> Widget -> Widget -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 - --- | Crop the specified widget on the top by the specified number of --- rows. Defers to the translated width for growth policy. -cropTopBy :: Int -> Widget -> Widget -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 - --- | Crop the specified widget on the bottom by the specified number of --- rows. Defers to the translated width for growth policy. -cropBottomBy :: Int -> Widget -> Widget -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 - --- | When rendering the specified widget, also register a cursor --- positioning request using the specified name and location. -showCursor :: Name -> Location -> Widget -> Widget -showCursor n cloc p = - Widget (hSize p) (vSize p) $ do - result <- render p - return $ result & cursorsL %~ (CursorLocation cloc (Just n):) - -hRelease :: Widget -> Maybe Widget -hRelease p = - case hSize p of - Fixed -> Just $ Widget Greedy (vSize p) $ withReaderT (& availWidthL .~ unrestricted) (render p) - Greedy -> Nothing - -vRelease :: Widget -> Maybe Widget -vRelease p = - case vSize p of - Fixed -> Just $ Widget (hSize p) Greedy $ withReaderT (& availHeightL .~ unrestricted) (render p) - Greedy -> Nothing - --- | Render the specified widget in a named viewport with the --- specified type. This permits widgets to be scrolled without being --- scrolling-aware. To make the most use of viewports, the specified --- widget should use the 'visible' combinator to make a "visibility --- request". This viewport combinator will then translate the resulting --- rendering to make the requested region visible. In addition, the --- 'Brick.Main.EventM' monad provides primitives to scroll viewports --- created by this function if 'visible' is not what you want. --- --- If a viewport receives more than one visibility request, only the --- first is honored. If a viewport receives more than one scrolling --- request from 'Brick.Main.EventM', all are honored in the order in --- which they are received. -viewport :: Name - -- ^ The name of the viewport (must be unique and stable for - -- reliable behavior) - -> ViewportType - -- ^ The type of viewport (indicates the permitted scrolling - -- direction) - -> Widget - -- ^ The widget to be rendered in the scrollable viewport - -> Widget -viewport vpname typ p = - Widget Greedy Greedy $ do - -- First, update the viewport size. - c <- getContext - let newVp = VP 0 0 newSize - newSize = (c^.availWidthL, c^.availHeightL) - doInsert (Just vp) = Just $ vp & vpSize .~ newSize - doInsert Nothing = Just newVp - - lift $ modify (& viewportMapL %~ (M.alter doInsert vpname)) - - -- Then render the sub-rendering with the rendering layout - -- constraint released (but raise an exception if we are asked to - -- render an infinitely-sized widget in the viewport's scrolling - -- dimension) - let Name vpn = vpname - release = case typ of - Vertical -> vRelease - Horizontal -> hRelease - Both -> \w -> vRelease w >>= hRelease - released = case release p of - Just w -> w - Nothing -> case typ of - Vertical -> error $ "tried to embed an infinite-height widget in vertical viewport " <> (show vpn) - Horizontal -> error $ "tried to embed an infinite-width widget in horizontal viewport " <> (show vpn) - Both -> error $ "tried to embed an infinite-width or infinite-height widget in 'Both' type viewport " <> (show vpn) - - initialResult <- render released - - -- If the rendering state includes any scrolling requests for this - -- viewport, apply those - reqs <- lift $ gets $ (^.scrollRequestsL) - let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs - when (not $ null relevantRequests) $ do - Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) - let updatedVp = applyRequests relevantRequests vp - applyRequests [] v = v - applyRequests (rq:rqs) v = - case typ of - Horizontal -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v - Vertical -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v - Both -> scrollTo Horizontal rq (initialResult^.imageL) $ - scrollTo Vertical rq (initialResult^.imageL) $ - applyRequests rqs v - lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) - return () - - -- If the sub-rendering requested visibility, update the scroll - -- state accordingly - when (not $ null $ initialResult^.visibilityRequestsL) $ do - Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) - let rq = head $ initialResult^.visibilityRequestsL - updatedVp = case typ of - Both -> scrollToView Horizontal rq $ scrollToView Vertical rq vp - Horizontal -> scrollToView typ rq vp - Vertical -> scrollToView typ rq vp - lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) - - -- If the size of the rendering changes enough to make the - -- viewport offsets invalid, reset them - Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) - let img = initialResult^.imageL - fixTop v = if V.imageHeight img < v^.vpSize._2 - then v & vpTop .~ 0 - else v - fixLeft v = if V.imageWidth img < v^.vpSize._1 - then v & vpLeft .~ 0 - else v - updateVp = case typ of - Both -> fixLeft . fixTop - Horizontal -> fixLeft - Vertical -> fixTop - lift $ modify (& viewportMapL %~ (M.insert vpname (updateVp vp))) - - -- Get the viewport state now that it has been updated. - Just vpFinal <- lift $ gets (M.lookup vpname . (^.viewportMapL)) - - -- 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 - - -- Return the translated result with the visibility requests - -- discarded - let translatedSize = ( translated^.imageL.to V.imageWidth - , translated^.imageL.to V.imageHeight - ) - case translatedSize of - (0, 0) -> return $ translated & imageL .~ (V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL)) - & visibilityRequestsL .~ mempty - _ -> render $ cropToContext - $ padBottom Max - $ padRight Max - $ Widget Fixed Fixed $ return $ translated & visibilityRequestsL .~ mempty - -scrollTo :: ViewportType -> ScrollRequest -> V.Image -> Viewport -> Viewport -scrollTo Both _ _ _ = error "BUG: called scrollTo on viewport type 'Both'" -scrollTo Vertical req img vp = vp & vpTop .~ newVStart - where - newVStart = clamp 0 (V.imageHeight img - vp^.vpSize._2) adjustedAmt - adjustedAmt = case req of - VScrollBy amt -> vp^.vpTop + amt - VScrollPage Up -> vp^.vpTop - vp^.vpSize._2 - VScrollPage Down -> vp^.vpTop + vp^.vpSize._2 - VScrollToBeginning -> 0 - VScrollToEnd -> V.imageHeight img - vp^.vpSize._2 - _ -> vp^.vpTop -scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart - where - newHStart = clamp 0 (V.imageWidth img - vp^.vpSize._1) adjustedAmt - adjustedAmt = case req of - HScrollBy amt -> vp^.vpLeft + amt - HScrollPage Up -> vp^.vpLeft - vp^.vpSize._1 - HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1 - HScrollToBeginning -> 0 - HScrollToEnd -> V.imageWidth img - vp^.vpSize._1 - _ -> vp^.vpLeft - -scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport -scrollToView Both _ _ = error "BUG: called scrollToView on 'Both' type viewport" -scrollToView Vertical rq vp = vp & vpTop .~ newVStart - where - curStart = vp^.vpTop - curEnd = curStart + vp^.vpSize._2 - reqStart = rq^.vrPositionL.rowL - - reqEnd = rq^.vrPositionL.rowL + rq^.vrSizeL._2 - newVStart :: Int - newVStart = if reqStart < curStart - then reqStart - else if reqStart > curEnd || reqEnd > curEnd - then reqEnd - vp^.vpSize._2 - else curStart -scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart - where - curStart = vp^.vpLeft - curEnd = curStart + vp^.vpSize._1 - reqStart = rq^.vrPositionL.columnL - - reqEnd = rq^.vrPositionL.columnL + rq^.vrSizeL._1 - newHStart :: Int - newHStart = if reqStart < curStart - then reqStart - else if reqStart > curEnd || reqEnd > curEnd - then reqEnd - vp^.vpSize._1 - else curStart - --- | Request that the specified widget be made visible when it is --- rendered inside a viewport. This permits widgets (whose sizes and --- positions cannot be known due to being embedded in arbitrary layouts) --- to make a request for a parent viewport to locate them and scroll --- enough to put them in view. This, together with 'viewport', is what --- makes the text editor and list widgets possible without making them --- deal with the details of scrolling state management. --- --- This does nothing if not rendered in a viewport. -visible :: Widget -> Widget -visible p = - Widget (hSize p) (vSize p) $ do - result <- render p - let imageSize = ( result^.imageL.to V.imageWidth - , result^.imageL.to V.imageHeight - ) - -- The size of the image to be made visible in a viewport must have - -- non-zero size in both dimensions. - return $ if imageSize^._1 > 0 && imageSize^._2 > 0 - then result & visibilityRequestsL %~ (VR (Location (0, 0)) imageSize :) - else result - --- | Similar to 'visible', request that a region (with the specified --- 'Location' as its origin and 'V.DisplayRegion' as its size) be made --- visible when it is rendered inside a viewport. The 'Location' is --- relative to the specified widget's upper-left corner of (0, 0). --- --- This does nothing if not rendered in a viewport. -visibleRegion :: Location -> V.DisplayRegion -> Widget -> Widget -visibleRegion vrloc sz p = - Widget (hSize p) (vSize p) $ do - result <- render p - -- The size of the image to be made visible in a viewport must have - -- non-zero size in both dimensions. - return $ if sz^._1 > 0 && sz^._2 > 0 - then result & visibilityRequestsL %~ (VR vrloc sz :) - else result - --- | Horizontal box layout: put the specified widgets next to each other --- in the specified order. Defers growth policies to the growth policies --- of both widgets. This operator is a binary version of 'hBox'. -(<+>) :: Widget - -- ^ Left - -> Widget - -- ^ Right - -> Widget -(<+>) a b = hBox [a, b] - --- | Vertical box layout: put the specified widgets one above the other --- in the specified order. Defers growth policies to the growth policies --- of both widgets. This operator is a binary version of 'vBox'. -(<=>) :: Widget - -- ^ Top - -> Widget - -- ^ Bottom - -> Widget -(<=>) a b = vBox [a, b] +{-# LANGUAGE MultiParamTypeClasses #-} +{-# 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. +module Brick.Widgets.Core + ( -- * Basic rendering primitives + TextWidth(..) + , emptyWidget + , raw + , txt + , txtWrap + , txtWrapWith + , str + , strWrap + , strWrapWith + , fill + , hyperlink + + -- * Padding + , Padding(..) + , padLeft + , padRight + , padTop + , padBottom + , padLeftRight + , padTopBottom + , padAll + + -- * Box layout + , (<=>) + , (<+>) + , hBox + , vBox + + -- * Limits + , hLimit + , hLimitPercent + , vLimit + , vLimitPercent + , setAvailableSize + + -- * Attribute management + , withDefAttr + , modifyDefAttr + , withAttr + , forceAttr + , forceAttrAllowStyle + , overrideAttr + , updateAttrMap + + -- * Border style management + , withBorderStyle + , joinBorders + , separateBorders + , freezeBorders + + -- * Cursor placement + , showCursor + , putCursor + + -- * Naming + , Named(..) + + -- * Translation and positioning + , translateBy + , relativeTo + + -- * Cropping + , cropLeftBy + , cropRightBy + , cropTopBy + , cropBottomBy + , cropLeftTo + , cropRightTo + , cropTopTo + , cropBottomTo + + -- * Extent reporting + , reportExtent + , clickable + + -- * Scrollable viewports + , viewport + , visible + , visibleRegion + , unsafeLookupViewport + , cached + + -- ** Viewport scroll bars + , withVScrollBars + , withHScrollBars + , withClickableHScrollBars + , withClickableVScrollBars + , withVScrollBarHandles + , withHScrollBarHandles + , withVScrollBarRenderer + , withHScrollBarRenderer + , VScrollbarRenderer(..) + , HScrollbarRenderer(..) + , verticalScrollbarRenderer + , horizontalScrollbarRenderer + , scrollbarAttr + , scrollbarTroughAttr + , scrollbarHandleAttr + , verticalScrollbar + , horizontalScrollbar + + -- ** Adding offsets to cursor positions and visibility requests + , addResultOffset + + -- ** Cropping results + , cropToContext + ) +where + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif + +import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, each, to, Lens') +import Lens.Micro.Mtl (use, (%=)) +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Reader +import qualified Data.Foldable as F +import Data.Traversable (for) +import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IMap as I +import qualified Data.Function as DF +import Data.List (sortBy, partition) +import Data.Maybe (fromMaybe) +import qualified Graphics.Vty as V +import Control.DeepSeq + +import Text.Wrap (wrapTextToLines, WrapSettings, defaultWrapSettings) + +import Brick.Types +import Brick.Types.Internal +import Brick.Widgets.Border.Style +import Brick.Util (clOffset, clamp) +import Brick.AttrMap +import Brick.Widgets.Internal +import qualified Brick.BorderMap as BM + +-- | The class of text types that have widths measured in terminal +-- columns. NEVER use 'length' etc. to measure the length of a string if +-- you need to compute how much screen space it will occupy; always use +-- 'textWidth'. +class TextWidth a where + textWidth :: a -> Int + +instance TextWidth T.Text where + textWidth = V.wcswidth . T.unpack + +instance (F.Foldable f) => TextWidth (f Char) where + textWidth = V.wcswidth . F.toList + +-- | The class of types that store interface element names. +class Named a n where + -- | Get the name of the specified value. + getName :: a -> n + +-- | When rendering the specified widget, use the specified border style +-- for any border rendering. +withBorderStyle :: BorderStyle -> Widget n -> Widget n +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. +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. +-- +-- This is the default for backwards compatibility. +separateBorders :: Widget n -> Widget n +separateBorders p = Widget (hSize p) (vSize p) $ + 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 borders cannot be thawed. +freezeBorders :: Widget n -> Widget n +freezeBorders p = Widget (hSize p) (vSize p) $ (bordersL %~ BM.clear) <$> render p + +-- | The empty widget. +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'). +-- +-- This function is the counterpart to 'makeVisible'; any visibility +-- requests made with 'makeVisible' must have a corresponding +-- 'reportExtent' in order to work. The 'clickable' function will also +-- work for this purpose to tell the renderer about the clickable +-- region. +reportExtent :: (Ord n) => n -> Widget n -> Widget n +reportExtent n p = + Widget (hSize p) (vSize p) $ do + result <- render p + let ext = Extent n (Location (0, 0)) sz + sz = ( result^.imageL.to V.imageWidth + , result^.imageL.to V.imageHeight + ) + -- If the reported extent also has a visibility request + -- from EventM via makeVisible, add a visibility request to + -- the render state so this gets scrolled into view by any + -- containing viewport. + vReqs <- use requestedVisibleNames_L + let addVisReq = if sz^._1 > 0 && sz^._2 > 0 && n `S.member` vReqs + then visibilityRequestsL %~ (VR (Location (0, 0)) sz :) + else id + return $ addVisReq $ result & extentsL %~ (ext:) + +-- | Request mouse click events on the specified widget. +-- +-- Regions used with 'clickable' can be scrolled into view with +-- 'makeVisible'. +clickable :: (Ord n) => n -> Widget n -> Widget n +clickable n p = + Widget (hSize p) (vSize p) $ do + clickableNamesL %= (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 + +-- | Make a widget from a string, but wrap the words in the input's +-- lines at the available width using the default wrapping settings. The +-- input string should not contain escape sequences or carriage returns. +-- +-- Unlike 'str', this is greedy horizontally. +strWrap :: String -> Widget n +strWrap = strWrapWith defaultWrapSettings + +-- | Make a widget from a string, but wrap the words in the input's +-- lines at the available width using the specified wrapping settings. +-- The input string should not contain escape sequences or carriage +-- returns. +-- +-- Unlike 'str', this is greedy horizontally. +strWrapWith :: WrapSettings -> String -> Widget n +strWrapWith settings t = txtWrapWith settings $ T.pack t + +-- | Make a widget from text, but wrap the words in the input's lines at +-- the available width using the default wrapping settings. The input +-- text should not contain escape sequences or carriage returns. +-- +-- Unlike 'txt', this is greedy horizontally. +txtWrap :: T.Text -> Widget n +txtWrap = txtWrapWith defaultWrapSettings + +-- | Make a widget from text, but wrap the words in the input's lines at +-- the available width using the specified wrapping settings. The input +-- text should not contain escape sequences or carriage returns. +-- +-- Unlike 'txt', this is greedy horizontally. +txtWrapWith :: WrapSettings -> T.Text -> Widget n +txtWrapWith settings s = + Widget Greedy Fixed $ do + c <- getContext + let theLines = fixEmpty <$> wrapTextToLines settings (c^.availWidthL) s + fixEmpty l | T.null l = " " + | otherwise = l + case force theLines of + [] -> return emptyResult + multiple -> + let maxLength = maximum $ textWidth <$> 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) " ") + in return $ emptyResult & imageL .~ (V.horizCat [V.vertCat lineImgs, padding]) + +-- | Build a widget from a 'String'. Behaves the same as 'txt' when the +-- input contains multiple lines. +-- +-- The input string must not contain tab characters. If it does, +-- interface corruption will result since the terminal will likely +-- render it as taking up more than a single column. The caller should +-- replace tabs with the appropriate number of spaces as desired. The +-- input string should not contain escape sequences or carriage returns. +str :: String -> Widget n +str = txt . T.pack + +-- | Build a widget from a 'T.Text' value. Breaks newlines up and +-- space-pads short lines out to the length of the longest line. +-- +-- The input string must not contain tab characters. If it does, +-- interface corruption will result since the terminal will likely +-- render it as taking up more than a single column. The caller should +-- replace tabs with the appropriate number of spaces as desired. The +-- input text should not contain escape sequences or carriage returns. +txt :: T.Text -> Widget n +txt s = + -- Although vty Image uses lazy Text internally, using lazy text at this + -- level may not be an improvement. Indeed it can be much worse, due + -- the overhead of lazy Text being significant compared to the typically + -- short string content used to compose UIs. + Widget Fixed Fixed $ do + c <- getContext + let theLines = fixEmpty <$> (dropUnused . T.lines) s + fixEmpty l = if T.null l then T.singleton ' ' else l + dropUnused l = takeColumnsT (availWidth c) <$> take (availHeight c) l + pure $ case theLines of + [] -> emptyResult + [one] -> emptyResult & imageL .~ (V.text' (c^.attrL) one) + multiple -> + let maxLength = maximum $ V.safeWctwidth <$> multiple + lineImgs = lineImg <$> multiple + lineImg lStr = V.text' (c^.attrL) + (lStr <> T.replicate (maxLength - V.safeWctwidth lStr) (T.singleton ' ')) + in emptyResult & imageL .~ (V.vertCat lineImgs) + +-- | Take up to the given width, having regard to character width. +takeColumnsT :: Int -> T.Text -> T.Text +takeColumnsT w s = T.take (fst $ T.foldl' f (0,0) s) s + where + -- The accumulator value is (index in Text value, width of Text so far) + f (i,z) c + -- Width was previously exceeded; continue with same values. + | z < 0 = (i, z) + -- Width exceeded. Signal this with z = -1. Index will no longer be + -- incremented. + -- + -- Why not short circuit (e.g. using foldlM construction)? + -- Because in the typical case, the Either allocation costs exceed + -- any benefits. The pathological case, string length >> width, is + -- probably rare. + | z + V.safeWcwidth c > w = (i, -1) + -- Width not yet exceeded. Increment index and add character width. + | otherwise = (i + 1, z + V.safeWcwidth c) + +-- | Hyperlink the given widget to the specified URL. Not all terminal +-- emulators support this. In those that don't, this should have no +-- discernible effect. +hyperlink :: T.Text -> Widget n -> Widget n +hyperlink url p = + Widget (hSize p) (vSize p) $ do + c <- getContext + let attr = (c^.attrL) `V.withURL` url + withReaderT (ctxAttrMapL %~ setDefaultAttr attr) (render p) + +-- | The type of padding. +data Padding = Pad Int + -- ^ Pad by the specified number of rows or columns. + | Max + -- ^ Pad up to the number of available rows or columns. + +-- | Pad the specified widget on the left. If max padding is used, this +-- grows greedily horizontally; otherwise it defers to the padded +-- widget. +padLeft :: Padding -> Widget n -> Widget n +padLeft padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (hLimit i, hSize p) + in Widget sz (vSize p) $ do + c <- getContext + let lim = case padding of + Max -> c^.availWidthL + Pad i -> c^.availWidthL - i + result <- render $ hLimit lim p + render $ (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') <+> + (Widget Fixed Fixed $ return result) + +-- | Pad the specified widget on the right. If max padding is used, +-- this grows greedily horizontally; otherwise it defers to the padded +-- widget. +padRight :: Padding -> Widget n -> Widget n +padRight padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (hLimit i, hSize p) + in Widget sz (vSize p) $ do + c <- getContext + let lim = case padding of + Max -> c^.availWidthL + Pad i -> c^.availWidthL - i + result <- render $ hLimit lim p + render $ (Widget Fixed Fixed $ return result) <+> + (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') + +-- | Pad the specified widget on the top. If max padding is used, this +-- grows greedily vertically; otherwise it defers to the padded widget. +padTop :: Padding -> Widget n -> Widget n +padTop padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (vLimit i, vSize p) + in Widget (hSize p) sz $ do + c <- getContext + let lim = case padding of + Max -> c^.availHeightL + Pad i -> c^.availHeightL - i + result <- render $ vLimit lim p + render $ (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') <=> + (Widget Fixed Fixed $ return result) + +-- | Pad the specified widget on the bottom. If max padding is used, +-- this grows greedily vertically; otherwise it defers to the padded +-- widget. +padBottom :: Padding -> Widget n -> Widget n +padBottom padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (vLimit i, vSize p) + in Widget (hSize p) sz $ do + c <- getContext + let lim = case padding of + Max -> c^.availHeightL + Pad i -> c^.availHeightL - i + result <- render $ vLimit lim p + render $ (Widget Fixed Fixed $ return result) <=> + (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') + +-- | Pad a widget on the left and right. Defers to the padded widget for +-- growth policy. +padLeftRight :: Int -> Widget n -> Widget n +padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w + +-- | Pad a widget on the top and bottom. Defers to the padded widget for +-- growth policy. +padTopBottom :: Int -> Widget n -> Widget n +padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w + +-- | Pad a widget on all sides. Defers to the padded widget for growth +-- policy. +padAll :: Int -> Widget n -> Widget n +padAll v w = padLeftRight v $ padTopBottom v w + +-- | Fill all available space with the specified character. Grows both +-- horizontally and vertically. +fill :: Char -> Widget n +fill ch = + Widget Greedy Greedy $ do + c <- getContext + return $ emptyResult & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL)) + +-- | Vertical box layout: put the specified widgets one above the other +-- 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 +vBox [a] = a +vBox pairs = renderBox vBoxRenderer pairs + +-- | Horizontal box layout: put the specified widgets next to each other +-- 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 +hBox [a] = a +hBox pairs = renderBox hBoxRenderer pairs + +-- | The process of rendering widgets in a box layout is exactly the +-- same except for the dimension under consideration (width vs. height), +-- in which case all of the same operations that consider one dimension +-- in the layout algorithm need to be switched to consider the other. +-- Because of this we fill a BoxRenderer with all of the functions +-- needed to consider the "primary" dimension (e.g. vertical if the +-- box layout is vertical) as well as the "secondary" dimension (e.g. +-- horizontal if the box layout is vertical). Doing this permits us to +-- have one implementation for box layout and parameterizing on the +-- orientation of all of the operations. +data BoxRenderer n = + BoxRenderer { contextPrimary :: Lens' (Context n) Int + , contextSecondary :: Lens' (Context n) Int + , imagePrimary :: V.Image -> Int + , imageSecondary :: V.Image -> Int + , limitPrimary :: Int -> Widget n -> Widget n + , primaryWidgetSize :: Widget n -> Size + , concatenatePrimary :: [V.Image] -> V.Image + , concatenateSecondary :: [V.Image] -> V.Image + , locationFromOffset :: Int -> Location + , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image + , loPrimary :: forall a. Lens' (Edges a) a -- lo: towards smaller coordinates in that dimension + , hiPrimary :: forall a. Lens' (Edges a) a -- hi: towards larger coordinates in that dimension + , loSecondary :: forall a. Lens' (Edges a) a + , hiSecondary :: forall a. Lens' (Edges a) a + , locationFromPrimarySecondary :: Int -> Int -> Location + , splitLoPrimary :: Int -> V.Image -> V.Image + , splitHiPrimary :: Int -> V.Image -> V.Image + , splitLoSecondary :: Int -> V.Image -> V.Image + , splitHiSecondary :: Int -> V.Image -> V.Image + , lookupPrimary :: Int -> BM.BorderMap DynBorder -> I.IMap DynBorder + , insertSecondary :: Location -> I.Run DynBorder -> BM.BorderMap DynBorder -> BM.BorderMap DynBorder + } + +vBoxRenderer :: BoxRenderer n +vBoxRenderer = + BoxRenderer { contextPrimary = availHeightL + , contextSecondary = availWidthL + , imagePrimary = V.imageHeight + , imageSecondary = V.imageWidth + , limitPrimary = vLimit + , primaryWidgetSize = vSize + , concatenatePrimary = V.vertCat + , concatenateSecondary = V.horizCat + , locationFromOffset = Location . (0 ,) + , padImageSecondary = \amt img a -> + let p = V.charFill a ' ' amt (V.imageHeight img) + in V.horizCat [img, p] + , loPrimary = eTopL + , hiPrimary = eBottomL + , loSecondary = eLeftL + , hiSecondary = eRightL + , locationFromPrimarySecondary = \r c -> Location (c, r) + , splitLoPrimary = V.cropBottom + , splitHiPrimary = \n img -> V.cropTop (V.imageHeight img-n) img + , splitLoSecondary = V.cropRight + , splitHiSecondary = \n img -> V.cropLeft (V.imageWidth img-n) img + , lookupPrimary = BM.lookupRow + , insertSecondary = BM.insertH + } + +hBoxRenderer :: BoxRenderer n +hBoxRenderer = + BoxRenderer { contextPrimary = availWidthL + , contextSecondary = availHeightL + , imagePrimary = V.imageWidth + , imageSecondary = V.imageHeight + , limitPrimary = hLimit + , primaryWidgetSize = hSize + , concatenatePrimary = V.horizCat + , concatenateSecondary = V.vertCat + , locationFromOffset = Location . (, 0) + , padImageSecondary = \amt img a -> + let p = V.charFill a ' ' (V.imageWidth img) amt + in V.vertCat [img, p] + , loPrimary = eLeftL + , hiPrimary = eRightL + , loSecondary = eTopL + , hiSecondary = eBottomL + , locationFromPrimarySecondary = \c r -> Location (c, r) + , splitLoPrimary = V.cropRight + , splitHiPrimary = \n img -> V.cropLeft (V.imageWidth img-n) img + , splitLoSecondary = V.cropBottom + , splitHiSecondary = \n img -> V.cropTop (V.imageHeight img-n) img + , lookupPrimary = BM.lookupCol + , insertSecondary = BM.insertV + } + +-- | Render a series of widgets in a box layout in the order given. +-- +-- The growth policy of a box layout is the most unrestricted of the +-- growth policies of the widgets it contains, so to determine the hSize +-- and vSize of the box we just take the maximum (using the Ord instance +-- for Size) of all of the widgets to be rendered in the box. +-- +-- Then the box layout algorithm proceeds as follows. We'll use +-- the vertical case to concretely describe the algorithm, but the +-- horizontal case can be envisioned just by exchanging all +-- "vertical"/"horizontal" and "rows"/"columns", etc., in the +-- description. +-- +-- The growth policies of the child widgets determine the order in which +-- they are rendered, i.e., the order in which space in the box is +-- allocated to widgets as the algorithm proceeds. This is because order +-- matters: if we render greedy widgets first, there will be no space +-- left for non-greedy ones. +-- +-- So we render all widgets with size 'Fixed' in the vertical dimension +-- first. Each is rendered with as much room as the overall box has, but +-- we assume that they will not be greedy and use it all. If they do, +-- maybe it's because the terminal is small and there just isn't enough +-- room to render everything. +-- +-- Then the remaining height is distributed evenly amongst all remaining +-- (greedy) widgets and they are rendered in sub-boxes that are as high +-- as this even slice of rows and as wide as the box is permitted to be. +-- We only do this step at all if rendering the non-greedy widgets left +-- us any space, i.e., if there were any rows left. +-- +-- After rendering the non-greedy and then greedy widgets, their images +-- are sorted so that they are stored in the order the original widgets +-- were given. All cursor locations and visibility requests in each +-- sub-widget are translated according to the position of the sub-widget +-- in the box. +-- +-- All images are padded to be as wide as the widest sub-widget to +-- prevent attribute over-runs. Without this step the attribute used by +-- a sub-widget may continue on in an undesirable fashion until it hits +-- something with a different attribute. To prevent this and to behave +-- in the least surprising way, we pad the image on the right with +-- whitespace using the context's current attribute. +-- +-- Finally, the padded images are concatenated together vertically and +-- returned along with the translated cursor positions and visibility +-- requests. +renderBox :: BoxRenderer n -> [Widget n] -> Widget n +renderBox br ws = + Widget (maximum $ hSize <$> ws) (maximum $ vSize <$> ws) $ do + c <- getContext + + let pairsIndexed = zip [(0::Int)..] ws + (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed) + pairsIndexed + + renderHi prim = do + remainingPrimary <- get + result <- lift $ render $ limitPrimary br remainingPrimary prim + result <$ (put $! remainingPrimary - (result^.imageL.(to $ imagePrimary br))) + + (renderedHis, remainingPrimary) <- + runStateT (traverse (traverse renderHi) his) (c ^. contextPrimary br) + + renderedLows <- case lows of + [] -> return [] + ls -> do + let primaryPerLow = remainingPrimary `div` length ls + rest = remainingPrimary - (primaryPerLow * length ls) + primaries = replicate rest (primaryPerLow + 1) <> + replicate (length ls - rest) primaryPerLow + + let renderLow ((i, prim), pri) = (i,) <$> render (limitPrimary br pri prim) + + if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return [] + + let rendered = sortBy (compare `DF.on` fst) $ renderedHis ++ renderedLows + allResults = snd <$> rendered + allImages = (^.imageL) <$> allResults + allTranslatedResults = flip evalState 0 $ for allResults $ \result -> do + offPrimary <- get + put $ offPrimary + (result ^. imageL . to (imagePrimary br)) + pure $ addResultOffset (locationFromOffset br offPrimary) result + -- Determine the secondary dimension value to pad to. In a + -- vertical box we want all images to be the same width to + -- avoid attribute over-runs or blank spaces with the wrong + -- attribute. In a horizontal box we want all images to have + -- the same height for the same reason. + maxSecondary = maximum $ imageSecondary br <$> allImages + padImage img = padImageSecondary br (maxSecondary - imageSecondary br img) + img (c^.attrL) + (imageRewrites, newBorders) = catAllBorders br (borders <$> allTranslatedResults) + rewrittenImages = zipWith (rewriteImage br) imageRewrites allImages + paddedImages = padImage <$> rewrittenImages + + cropResultToContext $ Result (concatenatePrimary br paddedImages) + (concatMap cursors allTranslatedResults) + (concatMap visibilityRequests allTranslatedResults) + (concatMap extents allTranslatedResults) + newBorders + +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 + -- horizontal border is being rewritten to accommodate a neighboring + -- vertical border, all we care about is that the two 'bsVertical's line up + -- sanely. After all, if the horizontal border's 'bsVertical' is the same + -- as the vertical one's, and the horizontal border's 'BorderStyle' is + -- self-consistent, then it will look "right" to rewrite according to the + -- horizontal border's 'BorderStyle'. + | dbStyle a == dbStyle b + && dbAttr a == dbAttr b + && a ^. dbSegmentsL.towardsB.bsAcceptL + && b ^. dbSegmentsL.towardsA.bsOfferL + && not (a ^. dbSegmentsL.towardsB.bsDrawL) -- don't bother doing an update if we don't need to + = 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 towardsA towardsB am bm = I.mapMaybe id + $ I.intersectionWith (catDynBorder towardsA towardsB) am bm + +-- | Given borders that should be placed next to each other (the first argument +-- on the right or bottom, and the second argument on the left or top), compute +-- new borders and the rewrites that should be done along the edges of the two +-- 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 br r l = if lCoord + 1 == rCoord + then ((lRe, rRe), lr') + else ((I.empty, I.empty), lr) + where + lr = BM.expand (BM.coordinates r) l `BM.unsafeUnion` + BM.expand (BM.coordinates l) r + lr' = id + . mergeIMap lCoord lIMap' + . mergeIMap rCoord rIMap' + $ lr + lCoord = BM.coordinates l ^. hiPrimary br + rCoord = BM.coordinates r ^. loPrimary br + lIMap = lookupPrimary br lCoord l + rIMap = lookupPrimary br rCoord r + lIMap' = catDynBorders (loPrimary br) (hiPrimary br) lIMap rIMap + rIMap' = catDynBorders (hiPrimary br) (loPrimary br) rIMap lIMap + lRe = renderDynBorder <$> lIMap' + rRe = renderDynBorder <$> rIMap' + mergeIMap p imap bm = F.foldl' + (\bm' (s,v) -> insertSecondary br (locationFromPrimarySecondary br p s) v bm') + bm + (I.unsafeToAscList imap) + +-- | Given a direction to concatenate borders in, and the border information +-- itself (which list is assumed to be already shifted so that borders do not +-- 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 _ [] = ([], 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 splitLo splitHi combine = (combine .) . go . offsets 0 . I.unsafeToAscList where + + -- convert absolute positions into relative ones + offsets _ [] = [] + offsets n ((n', r):nrs) = (n'-n, r) : offsets (n'+I.len r) nrs + + go [] old = [old] + -- TODO: might be nice to construct this image with fill rather than + -- replicate+char + go ((lo, I.Run len new):nrs) old + = [splitLo lo old] + ++ replicate len new + ++ go nrs (splitHi (lo+len) old) + +rewriteImage :: BoxRenderer n -> (I.IMap V.Image, I.IMap V.Image) -> V.Image -> V.Image +rewriteImage br (loRewrite, hiRewrite) old = rewriteHi . rewriteLo $ old where + size = imagePrimary br old + go = rewriteEdge (splitLoSecondary br) (splitHiSecondary br) (concatenateSecondary br) + rewriteLo img + | I.null loRewrite || size == 0 = img + | otherwise = concatenatePrimary br + [ go loRewrite (splitLoPrimary br 1 img) + , splitHiPrimary br 1 img + ] + rewriteHi img + | I.null hiRewrite || size == 0 = img + | otherwise = concatenatePrimary br + [ splitLoPrimary br (size-1) img + , go hiRewrite (splitHiPrimary br (size-1) img) + ] + +-- | Limit the space available to the specified widget to the specified +-- number of columns. This is important for constraining the horizontal +-- 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 + | 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 +-- inclusive. Values outside the valid range will be clamped to the +-- range endpoints. This is important for constraining the horizontal +-- 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 + | 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 + | 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 +-- inclusive. Values outside the valid range will be clamped to the +-- range endpoints. This is important for constraining the vertical +-- 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 + | 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 + | 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 +-- make further changes to the active drawing attribute, so this only +-- takes effect if nothing in the specified widget invokes 'withAttr' +-- or otherwise changes the rendering context's attribute setup. If you +-- want to prevent that, use 'forceAttr'. Attributes used this way still +-- get merged hierarchically and still fall back to the attribute map's +-- default attribute. If you want to change the default attribute, use +-- 'withDefAttr'. +-- +-- For example: +-- +-- @ +-- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) +-- , ("warning", bg magenta) +-- ] +-- +-- renderA :: (String, String) -> [Widget n] +-- renderA (a,b) = hBox [ str a +-- , str " is " +-- , withAttr "highlight" (str b) +-- ] +-- +-- render1 = renderA (\"Brick\", "fun") +-- render2 = withAttr "warning" render1 +-- @ +-- +-- In the example above, @render1@ will show @Brick is fun@ where the +-- first two words are white on a blue background and the last word +-- is yellow on a blue background. However, @render2@ will show the +-- first two words in white on magenta although the last word is still +-- rendered in yellow on blue. +withAttr :: AttrName -> Widget n -> Widget n +withAttr an p = + Widget (hSize p) (vSize p) $ + withReaderT (ctxAttrNameL .~ an) (render p) + +-- | Update the attribute map while rendering the specified widget: set +-- the map's default attribute to the one that we get by applying the +-- specified function to the current map's default attribute. This is a +-- variant of 'withDefAttr'; see the latter for more information. +modifyDefAttr :: (V.Attr -> V.Attr) -> Widget n -> Widget n +modifyDefAttr f p = + Widget (hSize p) (vSize p) $ do + c <- getContext + withReaderT (ctxAttrMapL %~ (setDefaultAttr (f $ getDefaultAttr (c^.ctxAttrMapL)))) (render p) + +-- | Update the attribute map used while rendering the specified +-- widget (and any sub-widgets): set its new *default* attribute +-- (i.e. the attribute components that will be applied if not +-- overridden by any more specific attributes) to the one that we get +-- by looking up the specified attribute name in the map. +-- +-- For example: +-- +-- @ +-- ... +-- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) +-- , ("warning", bg magenta) +-- , ("good", white `on` green) ] +-- ... +-- +-- renderA :: (String, String) -> [Widget n] +-- renderA (a,b) = hBox [ withAttr "good" (str a) +-- , str " is " +-- , withAttr "highlight" (str b) ] +-- +-- render1 = renderA (\"Brick\", "fun") +-- render2 = withDefAttr "warning" render1 +-- @ +-- +-- In the above, render1 will show "Brick is fun" where the first word +-- is white on a green background, the middle word is white on a blue +-- background, and the last word is yellow on a blue background. +-- However, render2 will show the first word in the same colors but +-- the middle word will be shown in whatever the terminal's normal +-- foreground is on a magenta background, and the third word will be +-- yellow on a magenta background. +withDefAttr :: AttrName -> Widget n -> Widget n +withDefAttr an p = + Widget (hSize p) (vSize p) $ do + c <- getContext + withReaderT (ctxAttrMapL %~ (setDefaultAttr (attrMapLookup an (c^.ctxAttrMapL)))) (render p) + +-- | While rendering the specified widget, use a transformed version +-- of the current attribute map. This is a very general function with +-- broad capabilities: you probably want a more specific function such +-- as 'withDefAttr' or 'withAttr'. +updateAttrMap :: (AttrMap -> AttrMap) -> Widget n -> Widget n +updateAttrMap f p = + Widget (hSize p) (vSize p) $ + withReaderT (ctxAttrMapL %~ f) (render p) + +-- | When rendering the specified widget, force all attribute lookups +-- in the attribute map to use the value currently assigned to the +-- specified attribute name. This means that the attribute lookups will +-- behave as if they all used the name specified here. That further +-- means that the resolved attribute will still inherit from its parent +-- entry in the attribute map as would normally be the case. If you +-- want to have more control over the resulting attribute, consider +-- 'modifyDefAttr'. +-- +-- For example: +-- +-- @ +-- ... +-- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) +-- , ("notice", fg red) ] +-- ... +-- +-- renderA :: (String, String) -> [Widget n] +-- renderA (a,b) = hBox [ withAttr "highlight" (str a) +-- , str " is " +-- , withAttr "highlight" (str b) +-- ] +-- +-- render1 = renderA ("Brick", "fun") +-- render2 = forceAttr "notice" render1 +-- @ +-- +-- In the above, render1 will show "Brick is fun" where the first and +-- last words are yellow on a blue background and the middle word is +-- white on a blue background. However, render2 will show all words +-- in red on a blue background. In both versions, the middle word +-- will be in white on a blue background. +forceAttr :: AttrName -> Widget n -> Widget n +forceAttr an p = + Widget (hSize p) (vSize p) $ do + 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. +-- +-- For example: +-- +-- @ +-- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) +-- , ("notice", fg red) +-- ] +-- +-- renderA :: (String, String) -> [Widget n] +-- renderA (a, b) = str a <+> str " is " <+> withAttr "highlight" (str b) +-- +-- render1 = withAttr "notice" $ renderA ("Brick", "fun") +-- render2 = overrideAttr "highlight" "notice" render1 +-- @ +-- +-- In the example above, @render1@ will show @Brick is fun@ where the +-- first two words are red on a blue background, but @fun@ is yellow on +-- a blue background. However, @render2@ will show all three words in +-- red on a blue background. +overrideAttr :: AttrName -> AttrName -> Widget n -> Widget n +overrideAttr targetName fromName = + updateAttrMap (mapAttrName fromName targetName) + +-- | Build a widget directly from a raw Vty image. +raw :: V.Image -> Widget n +raw img = Widget Fixed Fixed $ return $ emptyResult & imageL .~ img + +-- | Translate the specified widget by the specified offset amount. +-- 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)) + +-- | Given a 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 draws nothing on the basis that it only makes sense to draw what +-- was requested when the relative position can be known. +-- +-- 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 not being rendered. 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 @emptyWidget@. +-- +-- 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 = + Widget (hSize w) (vSize w) $ do + mExt <- lookupReportedExtent n + case mExt of + Nothing -> render emptyWidget + Just ext -> render $ translateBy (extentUpperLeft ext <> off) w + +-- | Crop the specified widget on the left by the specified number of +-- columns. Defers to the cropped widget for growth policy. +cropLeftBy :: Int -> Widget n -> Widget n +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 + render $ Widget (hSize p) (vSize p) $ + withReaderT (availWidthL .~ amt) $ + cropResultToContext $ + addResultOffset (Location (-1 * cols, 0)) $ + result & imageL %~ cropped + +-- | Crop the specified widget to the specified size from the left. +-- Defers to the cropped widget for growth policy. +cropLeftTo :: Int -> Widget n -> Widget n +cropLeftTo cols p = + Widget (hSize p) (vSize p) $ do + result <- render p + let w = V.imageWidth $ result^.imageL + amt = w - cols + if w <= cols + then return result + else render $ cropLeftBy amt $ Widget Fixed Fixed $ return result + +-- | Crop the specified widget on the right by the specified number of +-- columns. Defers to the cropped widget for growth policy. +cropRightBy :: Int -> Widget n -> Widget n +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 + withReaderT (availWidthL .~ amt) $ + cropResultToContext $ result & imageL %~ cropped + +-- | Crop the specified widget to the specified size from the right. +-- Defers to the cropped widget for growth policy. +cropRightTo :: Int -> Widget n -> Widget n +cropRightTo cols p = + Widget (hSize p) (vSize p) $ do + result <- render p + let w = V.imageWidth $ result^.imageL + amt = w - cols + if w <= cols + then return result + else render $ cropRightBy amt $ Widget Fixed Fixed $ return result + +-- | Crop the specified widget on the top by the specified number of +-- rows. Defers to the cropped widget for growth policy. +cropTopBy :: Int -> Widget n -> Widget n +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 + render $ Widget (hSize p) (vSize p) $ + withReaderT (availHeightL .~ amt) $ + cropResultToContext $ + addResultOffset (Location (0, -1 * rows)) $ + result & imageL %~ cropped + +-- | Crop the specified widget to the specified size from the top. +-- Defers to the cropped widget for growth policy. +cropTopTo :: Int -> Widget n -> Widget n +cropTopTo rows p = + Widget (hSize p) (vSize p) $ do + result <- render p + let h = V.imageHeight $ result^.imageL + amt = h - rows + if h <= rows + then return result + else render $ cropTopBy amt $ Widget Fixed Fixed $ return result + +-- | Crop the specified widget on the bottom by the specified number of +-- rows. Defers to the cropped widget for growth policy. +cropBottomBy :: Int -> Widget n -> Widget n +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 + withReaderT (availHeightL .~ amt) $ + cropResultToContext $ result & imageL %~ cropped + +-- | Crop the specified widget to the specified size from the bottom. +-- Defers to the cropped widget for growth policy. +cropBottomTo :: Int -> Widget n -> Widget n +cropBottomTo rows p = + Widget (hSize p) (vSize p) $ do + result <- render p + let h = V.imageHeight $ result^.imageL + amt = h - rows + if h <= rows + then return result + else render $ cropBottomBy amt $ Widget Fixed Fixed $ return result + +-- | When rendering the specified widget, also register a cursor +-- positioning request using the specified name and location. +showCursor :: n -> Location -> Widget n -> Widget n +showCursor n cloc p = Widget (hSize p) (vSize p) $ + (cursorsL %~ (CursorLocation cloc (Just n) True:)) <$> (render p) + +-- | When rendering the specified widget, also register a cursor +-- positioning request using the specified name and location. +-- The cursor will only be positioned but not made visible. +putCursor :: n -> Location -> Widget n -> Widget n +putCursor n cloc p = Widget (hSize p) (vSize p) $ + (cursorsL %~ (CursorLocation cloc (Just n) False:)) <$> (render p) + +hRelease :: Widget n -> Maybe (Widget n) +hRelease p = + case hSize p of + Fixed -> Just $ Widget Greedy (vSize p) $ + withReaderT (availWidthL .~ unrestricted) (render p) + Greedy -> Nothing + +vRelease :: Widget n -> Maybe (Widget n) +vRelease p = + case vSize p of + Fixed -> Just $ Widget (hSize p) Greedy $ + withReaderT (availHeightL .~ unrestricted) (render p) + Greedy -> Nothing + +-- | If the specified resource name has an entry in the rendering cache, +-- use the rendered version from the cache. If not, render the specified +-- widget and update the cache with the result. +-- +-- To ensure that mouse events are emitted correctly for cached widgets, +-- in addition to the rendered widget, we also cache (the names of) any +-- clickable extents that were rendered and restore that when utilizing +-- the cache. +-- +-- See also 'invalidateCacheEntry'. +cached :: (Ord n) => n -> Widget n -> Widget n +cached n w = + Widget (hSize w) (vSize w) $ do + result <- cacheLookup n + case result of + Just (clickables, prevResult) -> do + clickableNamesL %= (clickables ++) + return prevResult + Nothing -> do + wResult <- render w + clickables <- renderedClickables wResult + cacheUpdate n (clickables, wResult & visibilityRequestsL .~ mempty) + return wResult + 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 renderResult = do + allClickables <- use clickableNamesL + return [extentName e | e <- renderResult^.extentsL, extentName e `elem` allClickables] + +cacheLookup :: (Ord n) => n -> RenderM n (Maybe ([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 n r = lift $ modify (renderCacheL %~ M.insert n r) + +-- | Enable vertical scroll bars on all viewports in the specified +-- widget and draw them with the specified orientation. +withVScrollBars :: VScrollBarOrientation -> Widget n -> Widget n +withVScrollBars orientation w = + Widget (hSize w) (vSize w) $ + withReaderT (ctxVScrollBarOrientationL .~ Just orientation) (render w) + +-- | Enable scroll bar handles on all vertical scroll bars in the +-- specified widget. Handles appear at the ends of the scroll bar, +-- representing the "handles" that are typically clickable in +-- graphical UIs to move the scroll bar incrementally. Vertical +-- scroll bars are also clickable if mouse mode is enabled and if +-- 'withClickableVScrollBars' is used. +-- +-- This will only have an effect if 'withVScrollBars' is also called. +withVScrollBarHandles :: Widget n -> Widget n +withVScrollBarHandles w = + Widget (hSize w) (vSize w) $ + withReaderT (ctxVScrollBarShowHandlesL .~ True) (render w) + +-- | 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 :: 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 :: VScrollbarRenderer n +verticalScrollbarRenderer = + VScrollbarRenderer { renderVScrollbar = fill '█' + , renderVScrollbarTrough = fill ' ' + , renderVScrollbarHandleBefore = str "^" + , renderVScrollbarHandleAfter = str "v" + , scrollbarWidthAllocation = 1 + } + +-- | Enable horizontal scroll bars on all viewports in the specified +-- widget and draw them with the specified orientation. +withHScrollBars :: HScrollBarOrientation -> Widget n -> Widget n +withHScrollBars orientation w = + Widget (hSize w) (vSize w) $ + withReaderT (ctxHScrollBarOrientationL .~ Just orientation) (render w) + +-- | Enable mouse click reporting on horizontal scroll bars in the +-- specified widget. This must be used with 'withHScrollBars'. The +-- provided function is used to build a resource name containing the +-- scroll bar element clicked and the viewport name associated with the +-- scroll bar. It is usually a data constructor of the @n@ type. +withClickableHScrollBars :: (ClickableScrollbarElement -> n -> n) -> Widget n -> Widget n +withClickableHScrollBars f w = + Widget (hSize w) (vSize w) $ + withReaderT (ctxHScrollBarClickableConstrL .~ Just f) (render w) + +-- | Enable mouse click reporting on vertical scroll bars in the +-- specified widget. This must be used with 'withVScrollBars'. The +-- provided function is used to build a resource name containing the +-- scroll bar element clicked and the viewport name associated with the +-- scroll bar. It is usually a data constructor of the @n@ type. +withClickableVScrollBars :: (ClickableScrollbarElement -> n -> n) -> Widget n -> Widget n +withClickableVScrollBars f w = + Widget (hSize w) (vSize w) $ + withReaderT (ctxVScrollBarClickableConstrL .~ Just f) (render w) + +-- | Enable scroll bar handles on all horizontal scroll bars in +-- the specified widget. Handles appear at the ends of the scroll +-- bar, representing the "handles" that are typically clickable in +-- graphical UIs to move the scroll bar incrementally. Horizontal +-- scroll bars are also clickable if mouse mode is enabled and if +-- 'withClickableHScrollBars' is used. +-- +-- This will only have an effect if 'withHScrollBars' is also called. +withHScrollBarHandles :: Widget n -> Widget n +withHScrollBarHandles w = + Widget (hSize w) (vSize w) $ + withReaderT (ctxHScrollBarShowHandlesL .~ True) (render w) + +-- | 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 :: 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 :: HScrollbarRenderer n +horizontalScrollbarRenderer = + HScrollbarRenderer { renderHScrollbar = fill '█' + , renderHScrollbarTrough = fill ' ' + , renderHScrollbarHandleBefore = str "<" + , renderHScrollbarHandleAfter = str ">" + , scrollbarHeightAllocation = 1 + } + +-- | Render the specified widget in a named viewport with the +-- specified type. This permits widgets to be scrolled without being +-- scrolling-aware. To make the most use of viewports, the specified +-- widget should use the 'visible' combinator to make a "visibility +-- request". This viewport combinator will then translate the resulting +-- rendering to make the requested region visible. In addition, the +-- 'Brick.Main.EventM' monad provides primitives to scroll viewports +-- created by this function if 'visible' is not what you want. +-- +-- This function can automatically render vertical and horizontal scroll +-- bars if desired. To enable scroll bars, wrap your call to 'viewport' +-- with a call to 'withVScrollBars' and/or 'withHScrollBars'. If you +-- 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 +-- '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 +-- taking preference. If a viewport receives more than one scrolling +-- request from 'Brick.Main.EventM', all are honored in the order in +-- which they are received. +-- +-- Some caution should be advised when using this function. The viewport +-- renders its contents anew each time the viewport is drawn; in many +-- cases this is prohibitively expensive, and viewports should not be +-- used to display large contents for scrolling. This function is best +-- used when the contents are not too large OR when the contents are +-- large and render-cacheable. +-- +-- Also, be aware that there is a rich API for accessing viewport +-- information from within the 'EventM' monad; check the docs for +-- @Brick.Main@ to learn more about ways to get information about +-- viewports after they're drawn. +viewport :: (Ord n, Show n) + => n + -- ^ The name of the viewport (must be unique and stable for + -- reliable behavior) + -> ViewportType + -- ^ The type of viewport (indicates the permitted scrolling + -- direction) + -> Widget n + -- ^ The widget to be rendered in the scrollable viewport + -> Widget n +viewport vpname typ p = + clickable vpname $ Widget Greedy Greedy $ do + -- Obtain the scroll bar configuration. + c <- getContext + let vsOrientation = ctxVScrollBarOrientation c + hsOrientation = ctxHScrollBarOrientation c + vsRenderer = fromMaybe verticalScrollbarRenderer (ctxVScrollBarRenderer c) + hsRenderer = fromMaybe horizontalScrollbarRenderer (ctxHScrollBarRenderer c) + showVHandles = ctxVScrollBarShowHandles c + showHHandles = ctxHScrollBarShowHandles c + vsbClickableConstr = ctxVScrollBarClickableConstr c + hsbClickableConstr = ctxHScrollBarClickableConstr c + + -- Observe the viewport name so we can detect multiple uses of the + -- name. + let observeName :: (Ord n, Show n) => n -> RenderM n () + observeName n = do + observed <- use observedNamesL + case S.member n observed of + False -> observedNamesL %= S.insert n + True -> + error $ "Error: while rendering the interface, the name " <> show n <> + " was seen more than once. You should ensure that all of the widgets " <> + "in each interface have unique name values. This means either " <> + "using a different name type or adding constructors to your " <> + "existing one and using those to name your widgets. For more " <> + "information, see the \"Resource Names\" section of the Brick User Guide." + + observeName vpname + + -- Update the viewport size. + let newVp = VP 0 0 newSize (0, 0) + newSize = (newWidth, newHeight) + newWidth = c^.availWidthL - vSBWidth + newHeight = c^.availHeightL - hSBHeight + 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 + + lift $ modify (viewportMapL %~ (M.alter doInsert vpname)) + + -- Then render the viewport content widget with the rendering + -- layout constraint released (but raise an exception if we are + -- asked to render an infinitely-sized widget in the viewport's + -- scrolling dimension). Also note that for viewports that + -- only scroll in one direction, we apply a constraint in the + -- non-scrolling direction in case a scroll bar is present. + let release = case typ of + Vertical -> vRelease . hLimit newWidth + Horizontal -> hRelease . vLimit newHeight + Both -> vRelease >=> hRelease + released = case release p of + Just w -> w + Nothing -> case typ of + Vertical -> error $ "tried to embed an infinite-height " <> + "widget in vertical viewport " <> (show vpname) + Horizontal -> error $ "tried to embed an infinite-width " <> + "widget in horizontal viewport " <> (show vpname) + Both -> error $ "tried to embed an infinite-width or " <> + "infinite-height widget in 'Both' type " <> + "viewport " <> (show vpname) + + initialResult <- render released + + -- If the rendering state includes any scrolling requests for this + -- viewport, apply those + reqs <- lift $ gets (^.rsScrollRequestsL) + let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs + when (not $ null relevantRequests) $ do + mVp <- lift $ gets (^.viewportMapL.to (M.lookup vpname)) + case mVp of + Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" + Just vp -> do + let updatedVp = applyRequests relevantRequests vp + applyRequests [] v = v + applyRequests (rq:rqs) v = + case typ of + Horizontal -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v + Vertical -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v + Both -> scrollTo Horizontal rq (initialResult^.imageL) $ + scrollTo Vertical rq (initialResult^.imageL) $ + applyRequests rqs v + lift $ modify (viewportMapL %~ (M.insert vpname updatedVp)) + + -- If the sub-rendering requested visibility, update the scroll + -- state accordingly + when (not $ null $ initialResult^.visibilityRequestsL) $ do + mVp <- lift $ gets (^.viewportMapL.to (M.lookup vpname)) + case mVp of + Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" + Just vp -> do + let rqs = initialResult^.visibilityRequestsL + updateVp vp' rq = case typ of + Both -> scrollToView Horizontal rq $ scrollToView Vertical rq vp' + Horizontal -> scrollToView typ rq vp' + Vertical -> scrollToView typ rq vp' + lift $ modify (viewportMapL %~ (M.insert vpname $ foldl updateVp vp rqs)) + + -- If the size of the rendering changes enough to make the + -- viewport offsets invalid, reset them + mVp <- lift $ gets (^.viewportMapL.to (M.lookup vpname)) + vp <- case mVp of + Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" + Just v -> return v + + let img = initialResult^.imageL + fixTop v = if V.imageHeight img < v^.vpSize._2 + then v & vpTop .~ 0 + else v + fixLeft v = if V.imageWidth img < v^.vpSize._1 + then v & vpLeft .~ 0 + else v + updateContentSize v = v & vpContentSize .~ (V.imageWidth img, V.imageHeight img) + updateVp = updateContentSize . case typ of + Both -> fixLeft . fixTop + Horizontal -> fixLeft + Vertical -> fixTop + lift $ modify (viewportMapL %~ (M.insert vpname (updateVp vp))) + + -- Get the viewport state now that it has been updated. + mVpFinal <- lift $ gets (M.lookup vpname . (^.viewportMapL)) + vpFinal <- case mVpFinal of + 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 + + -- 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 orientation + vpname + vsbClickableConstr + showVHandles + (vpFinal^.vpSize._2) + (vpFinal^.vpTop) + (vpFinal^.vpContentSize._2) + combine = case orientation of + OnLeft -> (<+>) + OnRight -> flip (<+>) + in combine sb + addHScrollbar = case hsOrientation of + Nothing -> id + Just orientation -> + let sb = horizontalScrollbar hsRenderer orientation + vpname + hsbClickableConstr + showHHandles + (vpFinal^.vpSize._1) + (vpFinal^.vpLeft) + (vpFinal^.vpContentSize._1) + combine = case orientation of + OnTop -> (<=>) + OnBottom -> flip (<=>) + in combine sb + + -- Return the translated result with the visibility requests + -- discarded + let translatedSize = ( translated^.imageL.to V.imageWidth + , translated^.imageL.to V.imageHeight + ) + case translatedSize of + (0, 0) -> do + let spaceFill = V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL) + return $ translated & imageL .~ spaceFill + & visibilityRequestsL .~ mempty + & extentsL .~ mempty + _ -> render $ addVScrollbar + $ addHScrollbar + $ vLimit (vpFinal^.vpSize._2) + $ hLimit (vpFinal^.vpSize._1) + $ padBottom Max + $ padRight Max + $ Widget Fixed Fixed + $ return $ translated & visibilityRequestsL .~ mempty + +-- | The base attribute for scroll bars. +scrollbarAttr :: AttrName +scrollbarAttr = attrName "scrollbar" + +-- | The attribute for scroll bar troughs. This attribute is a +-- specialization of @scrollbarAttr@. +scrollbarTroughAttr :: AttrName +scrollbarTroughAttr = scrollbarAttr <> attrName "trough" + +-- | The attribute for scroll bar handles. This attribute is a +-- specialization of @scrollbarAttr@. +scrollbarHandleAttr :: AttrName +scrollbarHandleAttr = scrollbarAttr <> attrName "handle" + +maybeClick :: (Ord n) + => n + -> Maybe (ClickableScrollbarElement -> n -> n) + -> ClickableScrollbarElement + -> Widget n + -> Widget n +maybeClick _ Nothing _ w = w +maybeClick n (Just f) el w = clickable (f el n) w + +-- | Build a vertical scroll bar using the specified renderer and +-- settings. +-- +-- You probably don't want to use this directly; instead, +-- use @viewport@, @withVScrollBars@, and, if needed, +-- @withVScrollBarRenderer@. This is exposed so that if you want to +-- render a scroll bar of your own, you can do so outside the @viewport@ +-- context. +verticalScrollbar :: (Ord 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. + -> Maybe (ClickableScrollbarElement -> n -> n) + -- ^ Constructor for clickable scroll bar element names. + -> Bool + -- ^ Whether to display handles. + -> Int + -- ^ The total viewport height in effect. + -> Int + -- ^ The viewport vertical scrolling offset in effect. + -> Int + -- ^ The total viewport content height. + -> Widget n +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) + => 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. Will be given the element name and the + -- viewport name. + -> Int + -- ^ The total viewport height in effect. + -> Int + -- ^ The viewport vertical scrolling offset in effect. + -> Int + -- ^ The total viewport content height. + -> Widget n +verticalScrollbar' vsRenderer _ _ vpHeight _ 0 = + vLimit vpHeight $ renderVScrollbarTrough vsRenderer +verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight = + Widget Fixed Greedy $ do + c <- getContext + + -- Get the proportion of the total content that is visible + let visibleContentPercent :: Double + visibleContentPercent = fromIntegral vpHeight / + fromIntegral contentHeight + + ctxHeight = c^.availHeightL + + -- Then get the proportion of the scroll bar that + -- should be filled in + sbSize = min ctxHeight $ + max 1 $ + round $ visibleContentPercent * (fromIntegral ctxHeight) + + -- Then get the vertical offset of the scroll bar + -- itself + sbOffset = if vOffset == 0 + then 0 + else if vOffset == contentHeight - vpHeight + then ctxHeight - sbSize + else min (ctxHeight - sbSize - 1) $ + max 1 $ + round $ fromIntegral ctxHeight * + (fromIntegral vOffset / + fromIntegral contentHeight::Double) + + sbAbove = maybeClick n constr SBTroughBefore $ + withDefAttr scrollbarTroughAttr $ vLimit sbOffset $ + renderVScrollbarTrough vsRenderer + sbBelow = maybeClick n constr SBTroughAfter $ + withDefAttr scrollbarTroughAttr $ vLimit (ctxHeight - (sbOffset + sbSize)) $ + renderVScrollbarTrough vsRenderer + sbMiddle = maybeClick n constr SBBar $ + withDefAttr scrollbarAttr $ vLimit sbSize $ renderVScrollbar vsRenderer + + sb = if sbSize == ctxHeight + then vLimit sbSize $ + renderVScrollbarTrough vsRenderer + else vBox [sbAbove, sbMiddle, sbBelow] + + render sb + +-- | Build a horizontal scroll bar using the specified renderer and +-- settings. +-- +-- You probably don't want to use this directly; instead, use +-- @viewport@, @withHScrollBars@, and, if needed, +-- @withHScrollBarRenderer@. This is exposed so that if you want to +-- render a scroll bar of your own, you can do so outside the @viewport@ +-- context. +horizontalScrollbar :: (Ord 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. Will be given the element name and the + -- viewport name. + -> Bool + -- ^ Whether to show handles. + -> Int + -- ^ The total viewport width in effect. + -> Int + -- ^ The viewport horizontal scrolling offset in effect. + -> Int + -- ^ The total viewport content width. + -> Widget n +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) + => HScrollbarRenderer 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. + -> Int + -- ^ The total viewport width in effect. + -> Int + -- ^ The viewport horizontal scrolling offset in effect. + -> Int + -- ^ The total viewport content width. + -> Widget n +horizontalScrollbar' hsRenderer _ _ vpWidth _ 0 = + hLimit vpWidth $ renderHScrollbarTrough hsRenderer +horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth = + Widget Greedy Fixed $ do + c <- getContext + + -- Get the proportion of the total content that is visible + let visibleContentPercent :: Double + visibleContentPercent = fromIntegral vpWidth / + fromIntegral contentWidth + + ctxWidth = c^.availWidthL + + -- Then get the proportion of the scroll bar that + -- should be filled in + sbSize = min ctxWidth $ + max 1 $ + round $ visibleContentPercent * (fromIntegral ctxWidth) + + -- Then get the horizontal offset of the scroll bar itself + sbOffset = if hOffset == 0 + then 0 + else if hOffset == contentWidth - vpWidth + then ctxWidth - sbSize + else min (ctxWidth - sbSize - 1) $ + max 1 $ + round $ fromIntegral ctxWidth * + (fromIntegral hOffset / + fromIntegral contentWidth::Double) + + sbLeft = maybeClick n constr SBTroughBefore $ + withDefAttr scrollbarTroughAttr $ hLimit sbOffset $ + renderHScrollbarTrough hsRenderer + sbRight = maybeClick n constr SBTroughAfter $ + withDefAttr scrollbarTroughAttr $ hLimit (ctxWidth - (sbOffset + sbSize)) $ + renderHScrollbarTrough hsRenderer + sbMiddle = maybeClick n constr SBBar $ + withDefAttr scrollbarAttr $ hLimit sbSize $ renderHScrollbar hsRenderer + + sb = if sbSize == ctxWidth + then hLimit sbSize $ + renderHScrollbarTrough hsRenderer + else hBox [sbLeft, sbMiddle, sbRight] + + render sb + +-- | Given a name, obtain the viewport for that name by consulting the +-- viewport map in the rendering monad. NOTE! Some care must be taken +-- when calling this function, since it only returns useful values +-- after the viewport in question has been rendered. If you call this +-- function during rendering before a viewport has been rendered, you +-- may get nothing or you may get a stale version of the viewport. This +-- is because viewports are updated during rendering and the one you are +-- interested in may not have been rendered yet. So if you want to use +-- this, be sure you know what you are doing. +unsafeLookupViewport :: (Ord n) => n -> RenderM n (Maybe Viewport) +unsafeLookupViewport name = lift $ gets (M.lookup name . (^.viewportMapL)) + +scrollTo :: ViewportType -> ScrollRequest -> V.Image -> Viewport -> Viewport +scrollTo Both _ _ _ = error "BUG: called scrollTo on viewport type 'Both'" +scrollTo Vertical req img vp = vp & vpTop .~ newVStart + where + newVStart = clamp 0 (V.imageHeight img - vp^.vpSize._2) adjustedAmt + adjustedAmt = case req of + VScrollBy amt -> vp^.vpTop + amt + VScrollPage Up -> vp^.vpTop - vp^.vpSize._2 + VScrollPage Down -> vp^.vpTop + vp^.vpSize._2 + VScrollToBeginning -> 0 + VScrollToEnd -> V.imageHeight img - vp^.vpSize._2 + SetTop i -> i + _ -> vp^.vpTop +scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart + where + newHStart = clamp 0 (V.imageWidth img - vp^.vpSize._1) adjustedAmt + adjustedAmt = case req of + HScrollBy amt -> vp^.vpLeft + amt + HScrollPage Up -> vp^.vpLeft - vp^.vpSize._1 + HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1 + HScrollToBeginning -> 0 + HScrollToEnd -> V.imageWidth img - vp^.vpSize._1 + SetLeft i -> i + _ -> vp^.vpLeft + +scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport +scrollToView Both _ _ = error "BUG: called scrollToView on 'Both' type viewport" +scrollToView Vertical rq vp = vp & vpTop .~ newVStart + where + curStart = vp^.vpTop + curEnd = curStart + vp^.vpSize._2 + reqStart = rq^.vrPositionL.locationRowL + + reqEnd = rq^.vrPositionL.locationRowL + rq^.vrSizeL._2 + newVStart :: Int + newVStart = if reqStart < vStartEndVisible + then reqStart + else vStartEndVisible + vStartEndVisible = if reqEnd < curEnd + then curStart + else curStart + (reqEnd - curEnd) +scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart + where + curStart = vp^.vpLeft + curEnd = curStart + vp^.vpSize._1 + reqStart = rq^.vrPositionL.locationColumnL + + reqEnd = rq^.vrPositionL.locationColumnL + rq^.vrSizeL._1 + newHStart :: Int + newHStart = if reqStart < hStartEndVisible + then reqStart + else hStartEndVisible + hStartEndVisible = if reqEnd < curEnd + then curStart + else curStart + (reqEnd - curEnd) + +-- | Request that the specified widget be made visible when it is +-- rendered inside a viewport. This permits widgets (whose sizes and +-- positions cannot be known due to being embedded in arbitrary layouts) +-- to make a request for a parent viewport to locate them and scroll +-- enough to put them in view. This, together with 'viewport', is what +-- makes the text editor and list widgets possible without making them +-- deal with the details of scrolling state management. +-- +-- This does nothing if not rendered in a viewport. +visible :: Widget n -> Widget n +visible p = + Widget (hSize p) (vSize p) $ do + result <- render p + let imageSize = ( result^.imageL.to V.imageWidth + , result^.imageL.to V.imageHeight + ) + -- The size of the image to be made visible in a viewport must have + -- non-zero size in both dimensions. + return $ if imageSize^._1 > 0 && imageSize^._2 > 0 + then result & visibilityRequestsL %~ (VR (Location (0, 0)) imageSize :) + else result + +-- | Similar to 'visible', request that a region (with the specified +-- 'Location' as its origin and 'V.DisplayRegion' as its size) be made +-- visible when it is rendered inside a viewport. The 'Location' is +-- relative to the specified widget's upper-left corner of (0, 0). +-- +-- This does nothing if not rendered in a viewport. +visibleRegion :: Location -> V.DisplayRegion -> Widget n -> Widget n +visibleRegion vrloc sz p = + Widget (hSize p) (vSize p) $ do + result <- render p + -- The size of the image to be made visible in a viewport must have + -- non-zero size in both dimensions. + return $ if sz^._1 > 0 && sz^._2 > 0 + then result & visibilityRequestsL %~ (VR vrloc sz :) + else result + +-- | Horizontal box layout: put the specified widgets next to each other +-- in the specified order. Defers growth policies to the growth policies +-- of both widgets. This operator is a binary version of 'hBox'. +{-# NOINLINE (<+>) #-} +(<+>) :: Widget n + -- ^ Left + -> Widget n + -- ^ Right + -> Widget n +(<+>) a b = hBox [a, b] + +-- | Vertical box layout: put the specified widgets one above the other +-- in the specified order. Defers growth policies to the growth policies +-- of both widgets. This operator is a binary version of 'vBox'. +{-# NOINLINE (<=>) #-} +(<=>) :: Widget n + -- ^ Top + -> Widget n + -- ^ Bottom + -> Widget n +(<=>) a b = vBox [a, b] + +{-# RULES +"baseHbox" forall a b . a <+> b = hBox [a, b] +"hBox2" forall as bs . hBox [hBox as, hBox bs] = hBox (as ++ bs) +"hboxL" forall as b . hBox [hBox as, b] = hBox (as ++ [b]) +"hboxR" forall a bs . hBox [a, hBox bs] = hBox (a : bs) +"baseVbox" forall a b . a <=> b = vBox [a, b] +"vBox2" forall as bs . vBox [vBox as, vBox bs] = vBox (as ++ bs) +"vboxL" forall as b . vBox [vBox as, b] = vBox (as ++ [b]) +"vboxR" forall a bs . vBox [a, vBox bs] = vBox (a : bs) + #-} diff --git a/src/Brick/Widgets/Dialog.hs b/src/Brick/Widgets/Dialog.hs --- a/src/Brick/Widgets/Dialog.hs +++ b/src/Brick/Widgets/Dialog.hs @@ -1,17 +1,31 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | This module provides a simple dialog widget. You get to pick the -- dialog title, if any, as well as its body and buttons. +-- +-- Note that this dialog is really for simple use cases where you want +-- to get the user's answer to a question, such as "Would you like to +-- save changes before quitting?" As is typical in such cases, we assume +-- that this dialog box is used modally, meaning that while it is open +-- it is has exclusive input focus until it is closed. +-- +-- If you require something more sophisticated, you'll need to build it +-- yourself. You might also consider seeing the 'Brick.Forms' module for +-- help with input management and see the implementation of this module +-- to see how to reproduce a dialog-style UI. module Brick.Widgets.Dialog ( Dialog , dialogTitle - , dialogName , dialogButtons - , dialogSelectedIndex , dialogWidth -- * Construction and rendering , dialog , renderDialog + , getDialogFocus + , setDialogFocus + -- * Handling events + , handleDialogEvent -- * Getting a dialog's current value , dialogSelection -- * Attributes @@ -19,21 +33,21 @@ , buttonAttr , buttonSelectedAttr -- * Lenses - , dialogNameL , dialogButtonsL - , dialogSelectedIndexL , dialogWidthL , dialogTitleL ) where -import Control.Lens -import Control.Applicative +import Lens.Micro +import Lens.Micro.Mtl ((%=)) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid -import Data.List (intersperse) +#endif +import Data.List (intersperse, find) import Graphics.Vty.Input (Event(..), Key(..)) -import Brick.Util (clamp) +import Brick.Focus import Brick.Types import Brick.Widgets.Core import Brick.Widgets.Center @@ -41,81 +55,100 @@ import Brick.AttrMap -- | Dialogs present a window with a title (optional), a body, and --- buttons (optional). They provide a 'HandleEvent' instance that knows --- about Tab and Shift-Tab for changing which button is active. Dialog --- buttons are labeled with strings and map to values of type 'a', which --- you choose. +-- buttons (optional). Dialog buttons are labeled with strings and map +-- to values of type 'a', which you choose. -- --- Dialogs handle the following events by default: +-- Dialogs handle the following events by default with +-- handleDialogEvent: -- --- * Tab: selecte the next button --- * Shift-tab: select the previous button -data Dialog a = - Dialog { dialogName :: Name - -- ^ The dialog name - , dialogTitle :: Maybe String +-- * Tab or Right Arrow: select the next button +-- * Shift-tab or Left Arrow: select the previous button +data Dialog a n = + Dialog { dialogTitle :: Maybe (Widget n) -- ^ The dialog title - , dialogButtons :: [(String, a)] - -- ^ The dialog button labels and values - , dialogSelectedIndex :: Maybe Int - -- ^ The currently selected dialog button index (if any) + , dialogButtons :: [(String, n, a)] + -- ^ The dialog buttons' labels, resource names, and values , dialogWidth :: Int -- ^ The maximum width of the dialog + , dialogFocus :: FocusRing n + -- ^ The focus ring for the dialog's buttons } suffixLenses ''Dialog -instance HandleEvent (Dialog a) where - handleEvent ev d = - case ev of - EvKey (KChar '\t') [] -> return $ nextButtonBy 1 d - EvKey KBackTab [] -> return $ nextButtonBy (-1) d - _ -> return d +handleDialogEvent :: Event -> EventM n (Dialog a n) () +handleDialogEvent ev = do + case ev of + EvKey (KChar '\t') [] -> dialogFocusL %= focusNext + EvKey KRight [] -> dialogFocusL %= focusNext + EvKey KBackTab [] -> dialogFocusL %= focusPrev + EvKey KLeft [] -> dialogFocusL %= focusPrev + _ -> return () +-- | Set the focused button of a dialog. +setDialogFocus :: (Eq n) => n -> Dialog a n -> Dialog a n +setDialogFocus n d = d { dialogFocus = focusSetCurrent n $ dialogFocus d } + +-- | Get the focused button of a dialog. +getDialogFocus :: Dialog a n -> Maybe n +getDialogFocus = focusGetCurrent . dialogFocus + -- | Create a dialog. -dialog :: Name - -- ^ The dialog name, provided so that you can use this as a - -- basis for viewport names in the dialog if desired - -> Maybe String +dialog :: (Eq n) + => Maybe (Widget n) -- ^ The dialog title - -> Maybe (Int, [(String, a)]) - -- ^ The currently-selected button index (starting at zero) and - -- the button labels and values to use + -> Maybe (n, [(String, n, a)]) + -- ^ The currently-selected button resource name and the button + -- labels, resource names, and values to use for each button, + -- respectively -> Int -- ^ The maximum width of the dialog - -> Dialog a -dialog name title buttonData w = - let (buttons, idx) = case buttonData of - Nothing -> ([], Nothing) - Just (_, []) -> ([], Nothing) - Just (i, bs) -> (bs, Just $ clamp 0 (length bs - 1) i) - in Dialog name title buttons idx w + -> Dialog a n +dialog title buttonData w = + let (r, buttons) = case buttonData of + Nothing -> + (focusRing [], []) + Just (focName, entries) -> + let ns = (\(_, n, _) -> n) <$> entries + in (focusSetCurrent focName $ focusRing ns, entries) + in Dialog title buttons w r -- | The default attribute of the dialog dialogAttr :: AttrName -dialogAttr = "dialog" +dialogAttr = attrName "dialog" -- | The default attribute for all dialog buttons buttonAttr :: AttrName -buttonAttr = "button" +buttonAttr = attrName "button" -- | The attribute for the selected dialog button (extends 'dialogAttr') buttonSelectedAttr :: AttrName -buttonSelectedAttr = buttonAttr <> "selected" +buttonSelectedAttr = buttonAttr <> attrName "selected" --- | Render a dialog with the specified body widget. -renderDialog :: Dialog a -> Widget -> Widget +-- | Render a dialog with the specified body widget. This renders the +-- dialog as a layer, which makes this suitable as a top-level layer in +-- your rendering function to be rendered on top of the rest of your +-- interface. +renderDialog :: (Ord n) => Dialog a n -> Widget n -> Widget n renderDialog d body = let buttonPadding = str " " - mkButton (i, (s, _)) = let att = if Just i == d^.dialogSelectedIndexL - then buttonSelectedAttr - else buttonAttr - in withAttr att $ str $ " " <> s <> " " + foc = focusGetCurrent $ dialogFocus d + mkButton (s, n, _) = + let att = if Just n == foc + then buttonSelectedAttr + else buttonAttr + csr = if Just n == foc + then putCursor n (Location (1,0)) + else id + in csr $ + clickable n $ + withAttr att $ + str $ " " <> s <> " " buttons = hBox $ intersperse buttonPadding $ - mkButton <$> (zip [0..] (d^.dialogButtonsL)) + mkButton <$> (d^.dialogButtonsL) - doBorder = maybe border borderWithLabel (str <$> d^.dialogTitleL) - in center $ + doBorder = maybe border borderWithLabel (d^.dialogTitleL) + in centerLayer $ withDefAttr dialogAttr $ hLimit (d^.dialogWidthL) $ doBorder $ @@ -123,19 +156,12 @@ , hCenter buttons ] -nextButtonBy :: Int -> Dialog a -> Dialog a -nextButtonBy amt d = - let numButtons = length $ d^.dialogButtonsL - in if numButtons == 0 then d - else case d^.dialogSelectedIndexL of - Nothing -> d & dialogSelectedIndexL .~ (Just 0) - Just i -> d & dialogSelectedIndexL .~ (Just $ (i + amt) `mod` numButtons) - --- | Obtain the value associated with the dialog's currently-selected --- button, if any. This function is probably what you want when someone --- presses 'Enter' in a dialog. -dialogSelection :: Dialog a -> Maybe a -dialogSelection d = - case d^.dialogSelectedIndexL of - Nothing -> Nothing - Just i -> Just $ ((d^.dialogButtonsL) !! i)^._2 +-- | Obtain the resource name and value associated with the dialog's +-- currently-selected button, if any. The result of this function is +-- probably what you want when someone presses 'Enter' in a dialog. +dialogSelection :: (Eq n) => Dialog a n -> Maybe (n, a) +dialogSelection d = do + n' <- focusGetCurrent $ dialogFocus d + let matches (_, n, _) = n == n' + (_, n, a) <- find matches (d^.dialogButtonsL) + return (n, a) diff --git a/src/Brick/Widgets/Edit.hs b/src/Brick/Widgets/Edit.hs --- a/src/Brick/Widgets/Edit.hs +++ b/src/Brick/Widgets/Edit.hs @@ -1,36 +1,60 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} -- | This module provides a basic text editor widget. You'll need to -- embed an 'Editor' in your application state and transform it with --- 'handleEvent' when relevant events arrive. To get the contents +-- 'handleEditorEvent' when relevant events arrive. To get the contents -- of the editor, just use 'getEditContents'. To modify it, use the -- 'Z.TextZipper' interface with 'applyEdit'. -- --- The editor's 'HandleEvent' instance handles a set of basic input --- events that should suffice for most purposes; see the source for a --- complete list. +-- The editor's 'handleEditorEvent' function handles a set of basic +-- input events that should suffice for most purposes; see the source +-- for a complete list. +-- +-- Bear in mind that the editor provided by this module is intended to +-- provide basic input support for brick applications but it is not +-- intended to be a replacement for your favorite editor such as Vim or +-- Emacs. It is also not suitable for building sophisticated editors. If +-- you want to build your own editor, I suggest starting from scratch. module Brick.Widgets.Edit - ( Editor(editContents, editorName, editDrawContents) + ( Editor(editContents, editorName) -- * Constructing an editor , editor + , editorText -- * Reading editor contents , getEditContents + , getCursorPosition + -- * Handling events + , handleEditorEvent -- * Editing text , applyEdit -- * Lenses for working with editors , editContentsL - , editDrawContentsL -- * Rendering editors , renderEditor -- * Attributes , editAttr + , editFocusedAttr + -- * UTF-8 decoding of editor pastes + , DecodeUtf8(..) ) where -import Control.Lens +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import Lens.Micro import Graphics.Vty (Event(..), Key(..), Modifier(..)) -import qualified Data.Text.Zipper as Z +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Zipper as Z hiding ( textZipper ) +import qualified Data.Text.Zipper.Generic as Z +import qualified Data.Text.Zipper.Generic.Words as Z +import Data.Tuple (swap) import Brick.Types import Brick.Widgets.Core @@ -38,85 +62,189 @@ -- | Editor state. Editors support the following events by default: -- --- * Ctrl-a: go to beginning of line --- * Ctrl-e: go to end of line +-- * Mouse clicks: change cursor position +-- * Meta-<: go to beginning of file +-- * Meta->: go to end of file +-- * Ctrl-a, Home: go to beginning of line +-- * Ctrl-e, End: go to end of line -- * Ctrl-d, Del: delete character at cursor position +-- * Meta-d: delete word at cursor position -- * Backspace: delete character prior to cursor position -- * Ctrl-k: delete all from cursor to end of line +-- * Ctrl-u: delete all from cursor to beginning of line +-- * Ctrl-t: transpose character before cursor with the one at cursor position +-- * Meta-b: move one word to the left +-- * Ctrl-b: move one character to the left +-- * Meta-f: move one word to the right +-- * Ctrl-f: move one character to the right -- * Arrow keys: move cursor -- * Enter: break the current line at the cursor position -data Editor = - Editor { editContents :: Z.TextZipper String +-- * Paste: Bracketed Pastes from the terminal will be pasted, provided +-- the incoming data is UTF-8-encoded. +data Editor t n = + Editor { editContents :: Z.TextZipper t -- ^ The contents of the editor - , editDrawContents :: [String] -> Widget - -- ^ The function the editor uses to draw its contents - , editorName :: Name + , editorName :: n -- ^ The name of the editor } suffixLenses ''Editor -instance HandleEvent Editor where - handleEvent e ed = - let f = case e of - EvKey (KChar 'a') [MCtrl] -> Z.gotoBOL - EvKey (KChar 'e') [MCtrl] -> Z.gotoEOL - EvKey (KChar 'd') [MCtrl] -> Z.deleteChar - EvKey (KChar 'k') [MCtrl] -> Z.killToEOL - EvKey KEnter [] -> Z.breakLine - EvKey KDel [] -> Z.deleteChar - EvKey (KChar c) [] | c /= '\t' -> Z.insertChar c - EvKey KUp [] -> Z.moveUp - EvKey KDown [] -> Z.moveDown - EvKey KLeft [] -> Z.moveLeft - EvKey KRight [] -> Z.moveRight - EvKey KBS [] -> Z.deletePrevChar - _ -> id - in return $ applyEdit f ed +instance (Show t, Show n) => Show (Editor t n) where + show e = + concat [ "Editor { " + , "editContents = " <> show (editContents e) + , ", editorName = " <> show (editorName e) + , "}" + ] --- | Construct an editor. -editor :: Name +instance Named (Editor t n) n where + getName = editorName + +-- | Values that can be constructed by decoding bytestrings in UTF-8 +-- encoding. +class DecodeUtf8 t where + -- | Decode a bytestring assumed to be text in UTF-8 encoding. If + -- the decoding fails, return 'Left'. This must not raise + -- exceptions. + decodeUtf8 :: BS.ByteString -> Either String t + +instance DecodeUtf8 T.Text where + decodeUtf8 bs = case T.decodeUtf8' bs of + Left e -> Left $ show e + Right t -> Right t + +instance DecodeUtf8 String where + decodeUtf8 bs = T.unpack <$> decodeUtf8 bs + +handleEditorEvent :: (Eq n, DecodeUtf8 t, Eq t, Z.GenericTextZipper t) + => BrickEvent n e + -> EventM n (Editor t n) () +handleEditorEvent e = do + ed <- get + let f = case e of + VtyEvent ev -> + handleVtyEvent ev + MouseDown n _ _ (Location pos) | n == getName ed -> + Z.moveCursorClosest (swap pos) + _ -> id + handleVtyEvent ev = case ev of + EvPaste bs -> case decodeUtf8 bs of + Left _ -> id + Right t -> Z.insertMany t + EvKey (KChar 'a') [MCtrl] -> Z.gotoBOL + EvKey (KChar 'e') [MCtrl] -> Z.gotoEOL + EvKey (KChar 'd') [MCtrl] -> Z.deleteChar + EvKey (KChar 'd') [MMeta] -> Z.deleteWord + EvKey (KChar 'k') [MCtrl] -> Z.killToEOL + EvKey (KChar 'u') [MCtrl] -> Z.killToBOL + EvKey KEnter [] -> Z.breakLine + EvKey KDel [] -> Z.deleteChar + EvKey (KChar c) [] | c /= '\t' -> Z.insertChar c + EvKey KUp [] -> Z.moveUp + EvKey KDown [] -> Z.moveDown + EvKey KLeft [] -> Z.moveLeft + EvKey KRight [] -> Z.moveRight + EvKey (KChar 'b') [MCtrl] -> Z.moveLeft + EvKey (KChar 'f') [MCtrl] -> Z.moveRight + EvKey (KChar 'b') [MMeta] -> Z.moveWordLeft + EvKey (KChar 'f') [MMeta] -> Z.moveWordRight + EvKey KBS [] -> Z.deletePrevChar + EvKey (KChar 't') [MCtrl] -> Z.transposeChars + EvKey KHome [] -> Z.gotoBOL + EvKey KEnd [] -> Z.gotoEOL + EvKey (KChar '<') [MMeta] -> Z.gotoBOF + EvKey (KChar '>') [MMeta] -> Z.gotoEOF + _ -> id + put $ applyEdit f ed + +-- | Construct an editor over 'Text' values +editorText :: n + -- ^ The editor's name (must be unique) + -> Maybe Int + -- ^ The limit on the number of lines in the editor ('Nothing' + -- means no limit) + -> T.Text + -- ^ The initial content + -> Editor T.Text n +editorText = editor + +-- | Construct an editor over generic text values +editor :: Z.GenericTextZipper a + => n -- ^ The editor's name (must be unique) - -> ([String] -> Widget) - -- ^ The content rendering function -> Maybe Int -- ^ The limit on the number of lines in the editor ('Nothing' -- means no limit) - -> String + -> a -- ^ The initial content - -> Editor -editor name draw limit s = Editor (Z.stringZipper [s] limit) draw name + -> Editor a n +editor name limit s = Editor (Z.textZipper (Z.lines s) limit) name --- | Apply an editing operation to the editor's contents. Bear in mind --- that you should only apply zipper operations that operate on the --- current line; the editor will only ever render the first line of --- text. -applyEdit :: (Z.TextZipper String -> Z.TextZipper String) - -- ^ The 'Data.Text.Zipper' editing transformation to apply - -> Editor - -> Editor +-- | Apply an editing operation to the editor's contents. +-- +-- This is subject to the restrictions of the underlying text zipper; +-- for example, if the underlying zipper has a line limit configured, +-- any edits applied here will be ignored if they edit text outside +-- the line limit. +applyEdit :: (Z.TextZipper t -> Z.TextZipper t) + -- ^ The 'Z.TextZipper' editing transformation to apply + -> Editor t n + -> Editor t n applyEdit f e = e & editContentsL %~ f --- | The attribute assigned to the editor +-- | The attribute assigned to the editor when it does not have focus. editAttr :: AttrName -editAttr = "edit" +editAttr = attrName "edit" +-- | The attribute assigned to the editor when it has focus. Extends +-- 'editAttr'. +editFocusedAttr :: AttrName +editFocusedAttr = editAttr <> attrName "focused" + -- | Get the contents of the editor. -getEditContents :: Editor -> [String] +getEditContents :: Monoid t => Editor t n -> [t] getEditContents e = Z.getText $ e^.editContentsL --- | Turn an editor state value into a widget -renderEditor :: Editor -> Widget -renderEditor e = - let cp = Z.cursorPosition $ e^.editContentsL - cursorLoc = Location (cp^._2, cp^._1) +-- | Get the cursor position of the editor (row, column). +getCursorPosition :: Editor t n -> (Int, Int) +getCursorPosition e = Z.cursorPosition $ e^.editContentsL + +-- | Turn an editor state value into a widget. This uses the editor's +-- name for its scrollable viewport handle and the name is also used to +-- report mouse events. +renderEditor :: (Ord n, Show n, Monoid t, TextWidth t, Z.GenericTextZipper t) + => ([t] -> Widget n) + -- ^ The content drawing function + -> Bool + -- ^ Whether the editor has focus. It will report a cursor + -- position if and only if it has focus. + -> Editor t n + -- ^ The editor. + -> Widget n +renderEditor draw foc e = + let cp = Z.cursorPosition z + z = e^.editContentsL + toLeft = Z.take (cp^._2) (Z.currentLine z) + cursorLoc = Location (textWidth toLeft, cp^._1) limit = case e^.editContentsL.to Z.getLineLimit of Nothing -> id Just lim -> vLimit lim - in withAttr editAttr $ + atChar = charAtCursor $ e^.editContentsL + atCharWidth = maybe 1 textWidth atChar + in withAttr (if foc then editFocusedAttr else editAttr) $ limit $ viewport (e^.editorNameL) Both $ - showCursor (e^.editorNameL) cursorLoc $ - visibleRegion cursorLoc (1, 1) $ - e^.editDrawContentsL $ + (if foc then showCursor (e^.editorNameL) cursorLoc else id) $ + visibleRegion cursorLoc (atCharWidth, 1) $ + draw $ getEditContents e + +charAtCursor :: (Z.GenericTextZipper t) => Z.TextZipper t -> Maybe t +charAtCursor z = + let col = snd $ Z.cursorPosition z + curLine = Z.currentLine z + toRight = Z.drop col curLine + in if Z.length toRight > 0 + then Just $ Z.take 1 toRight + else Nothing diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/FileBrowser.hs @@ -0,0 +1,948 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | This module provides a file browser widget that allows users to +-- navigate directory trees, search for files and directories, and +-- select entries of interest. For a complete working demonstration of +-- this module, see @programs/FileBrowserDemo.hs@. +-- +-- To use this module: +-- +-- * Embed a 'FileBrowser' in your application state. +-- * Dispatch events to it in your event handler with +-- 'handleFileBrowserEvent'. +-- * Get the entry under the browser's cursor with 'fileBrowserCursor' +-- and get the entries selected by the user with 'Enter' or 'Space' +-- using 'fileBrowserSelection'. +-- * Inspect 'fileBrowserException' to determine whether the +-- file browser encountered an error when reading a directory in +-- 'setWorkingDirectory' or when changing directories in the event +-- handler. +-- +-- File browsers have a built-in user-configurable function to limit the +-- entries displayed that defaults to showing all files. For example, +-- an application might want to limit the browser to just directories +-- and XML files. That is accomplished by setting the filter with +-- 'setFileBrowserEntryFilter' and some examples are provided in this +-- module: 'fileTypeMatch' and 'fileExtensionMatch'. +-- +-- File browsers are styled using the provided collection of attribute +-- names, so add those to your attribute map to get the appearance you +-- want. File browsers also make use of a 'List' internally, so the +-- 'List' attributes will affect how the list appears. +-- +-- File browsers catch 'IOException's when changing directories. If a +-- call to 'setWorkingDirectory' triggers an 'IOException' while reading +-- the working directory, the resulting 'IOException' is stored in the +-- file browser and is accessible with 'fileBrowserException'. The +-- 'setWorkingDirectory' function clears the exception field if the +-- working directory is read successfully. The caller is responsible for +-- deciding when and whether to display the exception to the user. In +-- the event that an 'IOException' is raised as described here, the file +-- browser will always present @..@ as a navigation option to allow the +-- user to continue navigating up the directory tree. It does this even +-- if the current or parent directory does not exist or cannot be read, +-- so it is always safe to present a file browser for any working +-- directory. Bear in mind that the @..@ entry is always subjected to +-- filtering and searching. +module Brick.Widgets.FileBrowser + ( -- * Types + FileBrowser + , FileInfo(..) + , FileStatus(..) + , FileType(..) + + -- * Making a new file browser + , newFileBrowser + , selectNonDirectories + , selectDirectories + + -- * Manipulating a file browser's state + , setWorkingDirectory + , getWorkingDirectory + , updateFileBrowserSearch + , setFileBrowserEntryFilter + + -- * Actions + , actionFileBrowserBeginSearch + , actionFileBrowserSelectEnter + , actionFileBrowserSelectCurrent + , actionFileBrowserToggleCurrent + , actionFileBrowserListPageUp + , actionFileBrowserListPageDown + , actionFileBrowserListHalfPageUp + , actionFileBrowserListHalfPageDown + , actionFileBrowserListTop + , actionFileBrowserListBottom + , actionFileBrowserListNext + , actionFileBrowserListPrev + + -- * Handling events + , handleFileBrowserEvent + , maybeSelectCurrentEntry + + -- * Rendering + , renderFileBrowser + + -- * Getting information + , fileBrowserCursor + , fileBrowserIsSearching + , fileBrowserSelection + , fileBrowserException + , fileBrowserSelectable + , fileInfoFileType + + -- * Attributes + , fileBrowserAttr + , fileBrowserCurrentDirectoryAttr + , fileBrowserSelectionInfoAttr + , fileBrowserSelectedAttr + , fileBrowserDirectoryAttr + , fileBrowserBlockDeviceAttr + , fileBrowserRegularFileAttr + , fileBrowserCharacterDeviceAttr + , fileBrowserNamedPipeAttr + , fileBrowserSymbolicLinkAttr + , fileBrowserUnixSocketAttr + + -- * Example browser entry filters + , fileTypeMatch + , fileExtensionMatch + + -- * Lenses + , fileBrowserSelectableL + , fileInfoFilenameL + , fileInfoSanitizedFilenameL + , fileInfoFilePathL + , fileInfoFileStatusL + , fileInfoLinkTargetTypeL + , fileStatusSizeL + , fileStatusFileTypeL + + -- * Getters + , fileBrowserEntryFilterG + , fileBrowserWorkingDirectoryG + , fileBrowserEntriesG + , fileBrowserLatestResultsG + , fileBrowserSelectedFilesG + , fileBrowserNameG + , fileBrowserSearchStringG + , fileBrowserExceptionG + , fileBrowserSelectableG + + -- * Miscellaneous + , prettyFileSize + + -- * Utilities + , entriesForDirectory + , getFileInfo + ) +where + +import qualified Control.Exception as E +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 +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import Data.Int (Int64) +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 ((%=), use) +import Lens.Micro.TH (lensRules, generateUpdateableOptics) +import qualified Graphics.Vty as Vty +import qualified System.Directory as D +import qualified System.PosixCompat.Files as U +import qualified System.PosixCompat.Types as U +import qualified System.FilePath as FP +import Text.Printf (printf) + +import Brick.Types +import Brick.AttrMap (AttrName, attrName) +import Brick.Widgets.Core +import Brick.Widgets.List + +-- | A file browser's state. Embed this in your application state and +-- transform it with 'handleFileBrowserEvent' and the functions included +-- in this module. +data FileBrowser n = + FileBrowser { fileBrowserWorkingDirectory :: FilePath + , fileBrowserEntries :: List n FileInfo + , fileBrowserLatestResults :: [FileInfo] + , fileBrowserSelectedFiles :: Set.Set String + , fileBrowserName :: n + , fileBrowserEntryFilter :: Maybe (FileInfo -> Bool) + , fileBrowserSearchString :: Maybe T.Text + , fileBrowserException :: Maybe E.IOException + -- ^ The exception status of the latest directory + -- change. If 'Nothing', the latest directory change + -- was successful and all entries were read. Otherwise, + -- this contains the exception raised by the latest + -- directory change in case the calling application + -- needs to inspect or present the error to the user. + , fileBrowserSelectable :: FileInfo -> Bool + -- ^ The function that determines what kinds of entries + -- are selectable with in the event handler. Note that + -- if this returns 'True' for an entry, an @Enter@ or + -- @Space@ keypress selects that entry rather than doing + -- anything else; directory changes can only occur if + -- this returns 'False' for directories. + -- + -- Note that this is a record field so it can be used to + -- change the selection function. + } + +instance Named (FileBrowser n) n where + getName = getName . fileBrowserEntries + +-- | File status information. +data FileStatus = + FileStatus { fileStatusSize :: Int64 + -- ^ The size, in bytes, of this entry's file. + , fileStatusFileType :: Maybe FileType + -- ^ The type of this entry's file, if it could be + -- determined. + } + deriving (Show, Eq) + +-- | Information about a file entry in the browser. +data FileInfo = + FileInfo { fileInfoFilename :: String + -- ^ The filename of this entry, without its path. + -- This is not for display purposes; for that, use + -- 'fileInfoSanitizedFilename'. + , fileInfoSanitizedFilename :: String + -- ^ The filename of this entry with out its path, + -- sanitized of non-printable characters (replaced with + -- '?'). This is for display purposes only. + , fileInfoFilePath :: FilePath + -- ^ The full path to this entry's file. + , fileInfoFileStatus :: Either E.IOException FileStatus + -- ^ The file status if it could be obtained, or the + -- exception that was caught when attempting to read the + -- file's status. + , fileInfoLinkTargetType :: Maybe FileType + -- ^ If this entry is a symlink, this indicates the type of + -- file the symlink points to, if it could be obtained. + } + deriving (Show, Eq) + +-- | The type of file entries in the browser. +data FileType = + RegularFile + -- ^ A regular disk file. + | BlockDevice + -- ^ A block device. + | CharacterDevice + -- ^ A character device. + | NamedPipe + -- ^ A named pipe. + | Directory + -- ^ A directory. + | SymbolicLink + -- ^ A symbolic link. + | UnixSocket + -- ^ A Unix socket. + deriving (Read, Show, Eq) + +suffixLenses ''FileBrowser +suffixLensesWith "G" (lensRules & generateUpdateableOptics .~ False) ''FileBrowser +suffixLenses ''FileInfo +suffixLenses ''FileStatus + +-- | Make a new file browser state. The provided resource name will be +-- used to render the 'List' viewport of the browser. +-- +-- By default, the browser will show all files and directories +-- in its working directory. To change that behavior, see +-- 'setFileBrowserEntryFilter'. +newFileBrowser :: (FileInfo -> Bool) + -- ^ The function used to determine what kinds of entries + -- can be selected (see 'handleFileBrowserEvent'). A + -- good default is 'selectNonDirectories'. This can be + -- changed at 'any time with 'fileBrowserSelectable' or + -- its 'corresponding lens. + -> n + -- ^ The resource name associated with the browser's + -- entry listing. + -> Maybe FilePath + -- ^ The initial working directory that the browser + -- displays. If not provided, this defaults to the + -- executable's current working directory. + -> IO (FileBrowser n) +newFileBrowser selPredicate name mCwd = do + initialCwd <- FP.normalise <$> case mCwd of + Just path -> return $ removeTrailingSlash path + Nothing -> D.getCurrentDirectory + + let b = FileBrowser { fileBrowserWorkingDirectory = initialCwd + , fileBrowserEntries = list name mempty 1 + , fileBrowserLatestResults = mempty + , fileBrowserSelectedFiles = mempty + , fileBrowserName = name + , fileBrowserEntryFilter = Nothing + , fileBrowserSearchString = Nothing + , fileBrowserException = Nothing + , fileBrowserSelectable = selPredicate + } + + 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 +-- only directories, use 'selectDirectories'. +selectNonDirectories :: FileInfo -> Bool +selectNonDirectories i = + case fileInfoFileType i of + Just Directory -> False + Just SymbolicLink -> + case fileInfoLinkTargetType i of + Just Directory -> False + _ -> True + _ -> True + +-- | A file entry selector that permits selection of directories +-- only. This prevents directory navigation and only supports directory +-- selection. +selectDirectories :: FileInfo -> Bool +selectDirectories i = + case fileInfoFileType i of + Just Directory -> True + Just SymbolicLink -> fileInfoLinkTargetType i == Just Directory + _ -> False + +-- | Set the filtering function used to determine which entries in +-- the browser's current directory appear in the browser. 'Nothing' +-- indicates no filtering, meaning all entries will be shown. 'Just' +-- indicates a function that should return 'True' for entries that +-- should be permitted to appear. +-- +-- Note that this applies the filter after setting it by updating the +-- listed entries to reflect the result of the filter. That is unlike +-- setting the filter with the 'fileBrowserEntryFilterL' lens directly, +-- which just sets the filter but does not (and cannot) update the +-- listed entries. +setFileBrowserEntryFilter :: Maybe (FileInfo -> Bool) -> FileBrowser n -> FileBrowser n +setFileBrowserEntryFilter f b = + applyFilterAndSearch $ b & fileBrowserEntryFilterL .~ f + +-- | Set the working directory of the file browser. This scans the new +-- directory and repopulates the browser while maintaining any active +-- search string and/or entry filtering. +-- +-- If the directory scan raises an 'IOException', the exception is +-- stored in the browser and is accessible with 'fileBrowserException'. If +-- no exception is raised, the exception field is cleared. Regardless of +-- whether an exception is raised, @..@ is always presented as a valid +-- option in the browser. +setWorkingDirectory :: FilePath -> FileBrowser n -> IO (FileBrowser n) +setWorkingDirectory path b = do + entriesResult <- E.try $ entriesForDirectory path + + let (entries, exc) = case entriesResult of + Left (e::E.IOException) -> ([], Just e) + Right es -> (es, Nothing) + + allEntries <- if path == "/" then return entries else do + parentResult <- E.try $ parentOf path + return $ case parentResult of + Left (_::E.IOException) -> entries + Right parent -> parent : entries + + return $ setEntries allEntries b + & fileBrowserWorkingDirectoryL .~ path + & fileBrowserExceptionL .~ exc + & fileBrowserSelectedFilesL .~ mempty + +parentOf :: FilePath -> IO FileInfo +parentOf path = getFileInfo ".." $ FP.takeDirectory path + +-- | Build a 'FileInfo' for the specified file and path. If an +-- 'IOException' is raised while attempting to get the file information, +-- the 'fileInfoFileStatus' field is populated with the exception. +-- Otherwise it is populated with the 'FileStatus' for the file. +getFileInfo :: String + -- ^ The name of the file to inspect. This filename is only + -- used to set the 'fileInfoFilename' and sanitized filename + -- fields; the actual file to be inspected is referred + -- to by the second argument. This is decomposed so that + -- 'FileInfo's can be used to represent information about + -- entries like @..@, whose display names differ from their + -- physical paths. + -> FilePath + -- ^ The actual full path to the file or directory to + -- inspect. + -> IO FileInfo +getFileInfo name = go [] + where + go history fullPath = do + filePath <- D.makeAbsolute fullPath + statusResult <- E.try $ U.getSymbolicLinkStatus filePath + + let stat = do + status <- statusResult + let U.COff sz = U.fileSize status + return FileStatus { fileStatusFileType = fileTypeFromStatus status + , fileStatusSize = sz + } + + targetTy <- case fileStatusFileType <$> stat of + Right (Just SymbolicLink) -> do + targetPathResult <- E.try $ U.readSymbolicLink filePath + case targetPathResult of + Left (_::E.SomeException) -> return Nothing + Right targetPath -> + -- Watch out for recursive symlink chains: + -- if history starts repeating, abort the + -- symlink following process. + -- + -- Examples: + -- $ ln -s foo foo + -- + -- $ ln -s foo bar + -- $ ln -s bar foo + if targetPath `elem` history + then return Nothing + else do + targetInfo <- liftIO $ go (fullPath : history) targetPath + case fileInfoFileStatus targetInfo of + Right (FileStatus _ targetTy) -> return targetTy + _ -> return Nothing + _ -> return Nothing + + return FileInfo { fileInfoFilename = name + , fileInfoFilePath = filePath + , fileInfoSanitizedFilename = sanitizeFilename name + , fileInfoFileStatus = stat + , fileInfoLinkTargetType = targetTy + } + +-- | Get the file type for this file info entry. If the file type could +-- not be obtained due to an 'IOException', return 'Nothing'. +fileInfoFileType :: FileInfo -> Maybe FileType +fileInfoFileType i = + case fileInfoFileStatus i of + Left _ -> Nothing + Right stat -> fileStatusFileType stat + +-- | Get the working directory of the file browser. +getWorkingDirectory :: FileBrowser n -> FilePath +getWorkingDirectory = fileBrowserWorkingDirectory + +setEntries :: [FileInfo] -> FileBrowser n -> FileBrowser n +setEntries es b = + applyFilterAndSearch $ b & fileBrowserLatestResultsL .~ es + +-- | Returns whether the file browser is in search mode, i.e., the mode +-- in which user input affects the browser's active search string and +-- displayed entries. This is used to aid in event dispatching in the +-- calling program. +fileBrowserIsSearching :: FileBrowser n -> Bool +fileBrowserIsSearching b = isJust $ b^.fileBrowserSearchStringL + +-- | Get the entries chosen by the user, if any. Entries are chosen by +-- an 'Enter' or 'Space' keypress; if you want the entry under the +-- cursor, use 'fileBrowserCursor'. +fileBrowserSelection :: FileBrowser n -> [FileInfo] +fileBrowserSelection b = + let getEntry filename = fromJust $ F.find ((== filename) . fileInfoFilename) $ b^.fileBrowserLatestResultsL + in fmap getEntry $ F.toList $ b^.fileBrowserSelectedFilesL + +-- | Modify the file browser's active search string. This causes the +-- browser's displayed entries to change to those in its current +-- directory that match the search string, if any. If a search string +-- is provided, it is matched case-insensitively anywhere in file or +-- directory names. +updateFileBrowserSearch :: (Maybe T.Text -> Maybe T.Text) + -- ^ The search transformation. 'Nothing' + -- indicates that search mode should be off; + -- 'Just' indicates that it should be on and + -- that the provided search string should be + -- used. + -> FileBrowser n + -- ^ The browser to modify. + -> FileBrowser n +updateFileBrowserSearch f b = + let old = b^.fileBrowserSearchStringL + new = f $ b^.fileBrowserSearchStringL + oldLen = maybe 0 T.length old + newLen = maybe 0 T.length new + in if old == new + then b + else if oldLen == newLen + -- This case avoids a list rebuild and cursor position reset + -- when the search state isn't *really* changing. + then b & fileBrowserSearchStringL .~ new + else applyFilterAndSearch $ b & fileBrowserSearchStringL .~ new + +applyFilterAndSearch :: FileBrowser n -> FileBrowser n +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)) + (b^.fileBrowserSearchStringL) + match i = filterMatch i && searchMatch i + matching = filter match $ b^.fileBrowserLatestResultsL + in b { fileBrowserEntries = list (b^.fileBrowserNameL) (V.fromList matching) 1 } + +-- | Generate a textual abbreviation of a file size, e.g. "10.2M" or "12 +-- bytes". +prettyFileSize :: Int64 + -- ^ A file size in bytes. + -> T.Text +prettyFileSize i + | i >= 2 ^ (40::Int64) = T.pack $ format (i `divBy` (2 ** 40)) <> "T" + | i >= 2 ^ (30::Int64) = T.pack $ format (i `divBy` (2 ** 30)) <> "G" + | i >= 2 ^ (20::Int64) = T.pack $ format (i `divBy` (2 ** 20)) <> "M" + | i >= 2 ^ (10::Int64) = T.pack $ format (i `divBy` (2 ** 10)) <> "K" + | otherwise = T.pack $ show i <> " bytes" + where + format = printf "%0.1f" + divBy :: Int64 -> Double -> Double + divBy a b = ((fromIntegral a) :: Double) / b + +-- | Build a list of file info entries for the specified directory. This +-- function does not catch any exceptions raised by calling +-- 'makeAbsolute' or 'listDirectory', but it does catch exceptions on +-- a per-file basis. Any exceptions caught when inspecting individual +-- files are stored in the 'fileInfoFileStatus' field of each +-- 'FileInfo'. +-- +-- The entries returned are all entries in the specified directory +-- except for @.@ and @..@. Directories are always given first. Entries +-- are sorted in case-insensitive lexicographic order. +-- +-- This function is exported for those who want to implement their own +-- file browser using the types in this module. +entriesForDirectory :: FilePath -> IO [FileInfo] +entriesForDirectory rawPath = do + path <- D.makeAbsolute rawPath + + -- Get all entries except "." and "..", then sort them + dirContents <- D.listDirectory path + + infos <- forM dirContents $ \f -> do + getFileInfo f (path FP. f) + + let dirsFirst a b = if fileInfoFileType a == Just Directory && + fileInfoFileType b == Just Directory + then compare (toLower <$> fileInfoFilename a) + (toLower <$> fileInfoFilename b) + else if fileInfoFileType a == Just Directory && + fileInfoFileType b /= Just Directory + then LT + else if fileInfoFileType b == Just Directory && + fileInfoFileType a /= Just Directory + then GT + else compare (toLower <$> fileInfoFilename a) + (toLower <$> fileInfoFilename b) + + allEntries = sortBy dirsFirst infos + + return allEntries + +fileTypeFromStatus :: U.FileStatus -> Maybe FileType +fileTypeFromStatus s = + if | U.isBlockDevice s -> Just BlockDevice + | U.isCharacterDevice s -> Just CharacterDevice + | U.isNamedPipe s -> Just NamedPipe + | U.isRegularFile s -> Just RegularFile + | U.isDirectory s -> Just Directory + | U.isSocket s -> Just UnixSocket + | U.isSymbolicLink s -> Just SymbolicLink + | otherwise -> Nothing + +-- | Get the file information for the file under the cursor, if any. +fileBrowserCursor :: FileBrowser n -> Maybe FileInfo +fileBrowserCursor b = snd <$> listSelectedElement (b^.fileBrowserEntriesL) + +-- | Handle a Vty input event. Note that event handling can +-- cause a directory change so the caller should be aware that +-- 'fileBrowserException' may need to be checked after handling an +-- event in case an exception was triggered while scanning the working +-- directory. +-- +-- Events handled regardless of mode: +-- +-- * @Ctrl-b@: 'actionFileBrowserListPageUp' +-- * @Ctrl-f@: 'actionFileBrowserListPageDown' +-- * @Ctrl-d@: 'actionFileBrowserListHalfPageDown' +-- * @Ctrl-u@: 'actionFileBrowserListHalfPageUp' +-- * @Ctrl-n@: 'actionFileBrowserListNext' +-- * @Ctrl-p@: 'actionFileBrowserListPrev' +-- +-- Events handled only in normal mode: +-- +-- * @/@: 'actionFileBrowserBeginSearch' +-- * @Enter@: 'actionFileBrowserSelectEnter' +-- * @Space@: 'actionFileBrowserToggleCurrent' +-- * @g@: 'actionFileBrowserListTop' +-- * @G@: 'actionFileBrowserListBottom' +-- * @j@: 'actionFileBrowserListNext' +-- * @k@: 'actionFileBrowserListPrev' +-- +-- Events handled only in search mode: +-- +-- * @Esc@, @Ctrl-C@: cancel search mode +-- * Text input: update search string + +actionFileBrowserBeginSearch :: EventM n (FileBrowser n) () +actionFileBrowserBeginSearch = + modify $ updateFileBrowserSearch (const $ Just "") + +actionFileBrowserSelectEnter :: EventM n (FileBrowser n) () +actionFileBrowserSelectEnter = + maybeSelectCurrentEntry + +actionFileBrowserSelectCurrent :: EventM n (FileBrowser n) () +actionFileBrowserSelectCurrent = + selectCurrentEntry + +actionFileBrowserToggleCurrent :: EventM n (FileBrowser n) () +actionFileBrowserToggleCurrent = + toggleCurrentEntrySelected + +actionFileBrowserListPageUp :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListPageUp = + zoom fileBrowserEntriesL listMovePageUp + +actionFileBrowserListPageDown :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListPageDown = + zoom fileBrowserEntriesL listMovePageDown + +actionFileBrowserListHalfPageUp :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListHalfPageUp = + zoom fileBrowserEntriesL (listMoveByPages (-0.5::Double)) + +actionFileBrowserListHalfPageDown :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListHalfPageDown = + zoom fileBrowserEntriesL (listMoveByPages (0.5::Double)) + +actionFileBrowserListTop :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListTop = + fileBrowserEntriesL %= listMoveTo 0 + +actionFileBrowserListBottom :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListBottom = do + b <- get + let sz = length (listElements $ b^.fileBrowserEntriesL) + fileBrowserEntriesL %= listMoveTo (sz - 1) + +actionFileBrowserListNext :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListNext = + fileBrowserEntriesL %= listMoveBy 1 + +actionFileBrowserListPrev :: Ord n => EventM n (FileBrowser n) () +actionFileBrowserListPrev = + fileBrowserEntriesL %= listMoveBy (-1) + +handleFileBrowserEvent :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEvent e = do + b <- get + if fileBrowserIsSearching b + then handleFileBrowserEventSearching e + else handleFileBrowserEventNormal e + +safeInit :: T.Text -> T.Text +safeInit t | T.length t == 0 = t + | otherwise = T.init t + +handleFileBrowserEventSearching :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventSearching e = + case e of + Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl] -> + modify $ updateFileBrowserSearch (const Nothing) + Vty.EvKey Vty.KEsc [] -> + modify $ updateFileBrowserSearch (const Nothing) + Vty.EvKey Vty.KBS [] -> + modify $ updateFileBrowserSearch (fmap safeInit) + Vty.EvKey Vty.KEnter [] -> do + maybeSelectCurrentEntry + modify $ updateFileBrowserSearch (const Nothing) + Vty.EvKey (Vty.KChar c) [] -> + modify $ updateFileBrowserSearch (fmap (flip T.snoc c)) + _ -> + handleFileBrowserEventCommon e + +handleFileBrowserEventNormal :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventNormal e = + case e of + Vty.EvKey (Vty.KChar '/') [] -> + -- Begin file search + actionFileBrowserBeginSearch + Vty.EvKey Vty.KEnter [] -> + -- Select file or enter directory + actionFileBrowserSelectEnter + Vty.EvKey (Vty.KChar ' ') [] -> + -- Toggle selected status of current entry + actionFileBrowserToggleCurrent + _ -> + handleFileBrowserEventCommon e + +handleFileBrowserEventCommon :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventCommon e = + case e of + Vty.EvKey (Vty.KChar 'b') [Vty.MCtrl] -> + actionFileBrowserListPageUp + Vty.EvKey (Vty.KChar 'f') [Vty.MCtrl] -> + actionFileBrowserListPageDown + Vty.EvKey (Vty.KChar 'd') [Vty.MCtrl] -> + actionFileBrowserListHalfPageDown + Vty.EvKey (Vty.KChar 'u') [Vty.MCtrl] -> + actionFileBrowserListHalfPageUp + Vty.EvKey (Vty.KChar 'g') [] -> + actionFileBrowserListTop + Vty.EvKey (Vty.KChar 'G') [] -> + actionFileBrowserListBottom + Vty.EvKey (Vty.KChar 'j') [] -> + actionFileBrowserListNext + Vty.EvKey (Vty.KChar 'k') [] -> + actionFileBrowserListPrev + Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl] -> + actionFileBrowserListNext + Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl] -> + actionFileBrowserListPrev + _ -> + 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 +-- directory, set the browser's current path to the selected directory. +-- +-- Otherwise, return the browser state unchanged. +maybeSelectCurrentEntry :: EventM n (FileBrowser n) () +maybeSelectCurrentEntry = do + b <- get + 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 + 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 +-- information about the selected entry. +-- +-- Note that if the most recent file browser operation produced an +-- exception in 'fileBrowserException', that exception is not rendered +-- by this function. That exception needs to be rendered (if at all) by +-- the calling application. +-- +-- The file browser is greedy in both dimensions. +renderFileBrowser :: (Show n, Ord n) + => Bool + -- ^ Whether the file browser has input focus. + -> FileBrowser n + -- ^ The browser to render. + -> Widget n +renderFileBrowser foc b = + let maxFilenameLength = maximum $ length . fileInfoFilename <$> (b^.fileBrowserEntriesL) + cwdHeader = padRight Max $ + str $ sanitizeFilename $ fileBrowserWorkingDirectory b + selInfo = case listSelectedElement (b^.fileBrowserEntriesL) of + Nothing -> vLimit 1 $ fill ' ' + Just (_, i) -> padRight Max $ selInfoFor i + fileTypeLabel Nothing = "unknown" + fileTypeLabel (Just t) = + case t of + RegularFile -> "file" + BlockDevice -> "block device" + CharacterDevice -> "character device" + NamedPipe -> "pipe" + Directory -> "directory" + SymbolicLink -> "symbolic link" + UnixSocket -> "socket" + selInfoFor i = + let label = case fileInfoFileStatus i of + Left _ -> "unknown" + Right stat -> + let maybeSize = if fileStatusFileType stat == Just RegularFile + then ", " <> prettyFileSize (fileStatusSize stat) + else "" + in fileTypeLabel (fileStatusFileType stat) <> maybeSize + in txt $ T.pack (fileInfoSanitizedFilename i) <> ": " <> label + + maybeSearchInfo = case b^.fileBrowserSearchStringL of + Nothing -> emptyWidget + Just s -> padRight Max $ + txt "Search: " <+> + showCursor (b^.fileBrowserNameL) (Location (T.length s, 0)) (txt s) + + in withDefAttr fileBrowserAttr $ + vBox [ withDefAttr fileBrowserCurrentDirectoryAttr cwdHeader + , renderList (renderFileInfo foc maxFilenameLength (b^.fileBrowserSelectedFilesL) (b^.fileBrowserNameL)) + foc (b^.fileBrowserEntriesL) + , maybeSearchInfo + , withDefAttr fileBrowserSelectionInfoAttr selInfo + ] + +renderFileInfo :: Bool -> Int -> Set.Set String -> n -> Bool -> FileInfo -> Widget n +renderFileInfo foc maxLen selFiles n listSel info = + (if foc + then (if listSel then forceAttr listSelectedFocusedAttr + else if sel then forceAttr fileBrowserSelectedAttr else id) + else (if listSel then forceAttr listSelectedAttr + else if sel then forceAttr fileBrowserSelectedAttr else id)) $ + padRight Max body + where + sel = fileInfoFilename info `Set.member` selFiles + addAttr = maybe id (withDefAttr . attrForFileType) (fileInfoFileType info) + body = addAttr (hLimit (maxLen + 1) $ + padRight Max $ + (if foc && listSel then putCursor n (Location (0,0)) else id) $ + str $ fileInfoSanitizedFilename info <> suffix) + suffix = (if fileInfoFileType info == Just Directory then "/" else "") <> + (if sel then "*" else "") + +-- | Sanitize a filename for terminal display, replacing non-printable +-- characters with '?'. +sanitizeFilename :: String -> String +sanitizeFilename = fmap toPrint + where + toPrint c | isPrint c = c + | otherwise = '?' + +attrForFileType :: FileType -> AttrName +attrForFileType RegularFile = fileBrowserRegularFileAttr +attrForFileType BlockDevice = fileBrowserBlockDeviceAttr +attrForFileType CharacterDevice = fileBrowserCharacterDeviceAttr +attrForFileType NamedPipe = fileBrowserNamedPipeAttr +attrForFileType Directory = fileBrowserDirectoryAttr +attrForFileType SymbolicLink = fileBrowserSymbolicLinkAttr +attrForFileType UnixSocket = fileBrowserUnixSocketAttr + +-- | The base attribute for all file browser attributes. +fileBrowserAttr :: AttrName +fileBrowserAttr = attrName "fileBrowser" + +-- | The attribute used for the current directory displayed at the top +-- of the browser. +fileBrowserCurrentDirectoryAttr :: AttrName +fileBrowserCurrentDirectoryAttr = fileBrowserAttr <> attrName "currentDirectory" + +-- | The attribute used for the entry information displayed at the +-- bottom of the browser. +fileBrowserSelectionInfoAttr :: AttrName +fileBrowserSelectionInfoAttr = fileBrowserAttr <> attrName "selectionInfo" + +-- | The attribute used to render directory entries. +fileBrowserDirectoryAttr :: AttrName +fileBrowserDirectoryAttr = fileBrowserAttr <> attrName "directory" + +-- | The attribute used to render block device entries. +fileBrowserBlockDeviceAttr :: AttrName +fileBrowserBlockDeviceAttr = fileBrowserAttr <> attrName "block" + +-- | The attribute used to render regular file entries. +fileBrowserRegularFileAttr :: AttrName +fileBrowserRegularFileAttr = fileBrowserAttr <> attrName "regular" + +-- | The attribute used to render character device entries. +fileBrowserCharacterDeviceAttr :: AttrName +fileBrowserCharacterDeviceAttr = fileBrowserAttr <> attrName "char" + +-- | The attribute used to render named pipe entries. +fileBrowserNamedPipeAttr :: AttrName +fileBrowserNamedPipeAttr = fileBrowserAttr <> attrName "pipe" + +-- | The attribute used to render symbolic link entries. +fileBrowserSymbolicLinkAttr :: AttrName +fileBrowserSymbolicLinkAttr = fileBrowserAttr <> attrName "symlink" + +-- | The attribute used to render Unix socket entries. +fileBrowserUnixSocketAttr :: AttrName +fileBrowserUnixSocketAttr = fileBrowserAttr <> attrName "unixSocket" + +-- | The attribute used for selected entries in the file browser. +fileBrowserSelectedAttr :: AttrName +fileBrowserSelectedAttr = fileBrowserAttr <> attrName "selected" + +-- | A file type filter for use with 'setFileBrowserEntryFilter'. This +-- filter permits entries whose file types are in the specified list. +fileTypeMatch :: [FileType] -> FileInfo -> Bool +fileTypeMatch tys i = maybe False (`elem` tys) $ fileInfoFileType i + +-- | A filter that matches any directory regardless of name, or any +-- regular file with the specified extension. For example, an extension +-- argument of @"xml"@ would match regular files @test.xml@ and +-- @TEST.XML@ and it will match directories regardless of name. +-- +-- This matcher also matches symlinks if and only if their targets are +-- directories. This is intended to make it possible to use this matcher +-- to find files with certain extensions, but also support directory +-- traversal via symlinks. +fileExtensionMatch :: String -> FileInfo -> Bool +fileExtensionMatch ext i = case fileInfoFileType i of + Just Directory -> True + Just RegularFile -> ('.' : (toLower <$> ext)) `isSuffixOf` (toLower <$> fileInfoFilename i) + Just SymbolicLink -> case fileInfoLinkTargetType i of + Just Directory -> True + _ -> False + _ -> False diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -3,43 +3,197 @@ ( renderFinal , cropToContext , cropResultToContext + , renderDynBorder + , renderWidget ) where -import Control.Applicative -import Control.Lens ((^.), (&), (%~)) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader -import Data.Default +import Lens.Micro ((^.), (&), (%~), (.~)) +import Lens.Micro.Mtl ((%=)) +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Reader +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Map as M +import qualified Data.Set as S import qualified Graphics.Vty as V import Brick.Types import Brick.Types.Internal import Brick.AttrMap +import Brick.Widgets.Border.Style +import Brick.BorderMap (BorderMap) +import qualified Brick.BorderMap as BM -renderFinal :: AttrMap - -> [Widget] +renderFinal :: (Ord n) + => AttrMap + -> [Widget n] -> V.DisplayRegion - -> ([CursorLocation] -> Maybe CursorLocation) - -> RenderState - -> (RenderState, V.Picture, Maybe CursorLocation) -renderFinal aMap layerRenders sz chooseCursor rs = (newRS, pic, theCursor) + -> ([CursorLocation n] -> Maybe (CursorLocation n)) + -> RenderState n + -> (RenderState n, V.Picture, Maybe (CursorLocation n), [Extent n]) +renderFinal aMap layerRenders (w, h) chooseCursor rs = + (newRS, picWithBg, theCursor, concat layerExtents) where - (layerResults, !newRS) = flip runState rs $ sequence $ + -- 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 + + (layerResults, !newRS) = flip runState resetRs $ sequence $ (\p -> runReaderT p ctx) <$> - (render <$> cropToContext <$> layerRenders) - ctx = Context def (fst sz) (snd sz) def aMap - pic = V.picForLayers $ uncurry V.resize sz <$> (^.imageL) <$> layerResults - layerCursors = (^.cursorsL) <$> layerResults + (\layerWidget -> do + result <- render $ cropToContext layerWidget + forM_ (result^.extentsL) $ \e -> + reportedExtentsL %= M.insert (extentName e) e + return result + ) <$> reverse layerRenders + + ctx = Context { ctxAttrName = mempty + , availWidth = w + , availHeight = h + , windowWidth = w + , windowHeight = h + , ctxBorderStyle = defaultBorderStyle + , ctxAttrMap = aMap + , ctxDynBorders = False + , ctxVScrollBarOrientation = Nothing + , ctxVScrollBarRenderer = Nothing + , ctxHScrollBarOrientation = Nothing + , ctxHScrollBarRenderer = Nothing + , ctxHScrollBarShowHandles = False + , ctxVScrollBarShowHandles = False + , ctxHScrollBarClickableConstr = Nothing + , ctxVScrollBarClickableConstr = Nothing + } + + layersTopmostFirst = reverse layerResults + pic = V.picForLayers $ V.resize w h <$> (^.imageL) <$> layersTopmostFirst + + -- 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 -- | After rendering the specified widget, crop its result image to the -- dimensions in the rendering context. -cropToContext :: Widget -> Widget +cropToContext :: Widget n -> Widget n cropToContext p = - Widget (hSize p) (vSize p) $ (render p >>= cropResultToContext) + Widget (hSize p) (vSize p) (render p >>= cropResultToContext) -cropResultToContext :: Result -> RenderM Result +cropResultToContext :: Result n -> RenderM n (Result n) cropResultToContext result = do c <- getContext - return $ result & imageL %~ (V.crop (c^.availWidthL) (c^.availHeightL)) + return $ result & imageL %~ cropImage c + & cursorsL %~ cropCursors c + & extentsL %~ cropExtents c + & bordersL %~ cropBorders c + +cropImage :: Context n -> V.Image -> V.Image +cropImage c = V.crop (max 0 $ c^.availWidthL) (max 0 $ c^.availHeightL) + +cropCursors :: Context n -> [CursorLocation n] -> [CursorLocation n] +cropCursors ctx cs = mapMaybe cropCursor cs + where + -- A cursor location is removed if it is not within the region + -- described by the context. + cropCursor c | outOfContext c = Nothing + | otherwise = Just c + outOfContext c = + or [ c^.cursorLocationL.locationRowL < 0 + , c^.cursorLocationL.locationColumnL < 0 + , c^.cursorLocationL.locationRowL >= ctx^.availHeightL + , c^.cursorLocationL.locationColumnL >= ctx^.availWidthL + ] + +cropExtents :: Context n -> [Extent n] -> [Extent n] +cropExtents ctx es = mapMaybe cropExtent es + where + cropExtent (Extent n (Location (c, r)) (w, h)) = + -- 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 + { eTop = 0 + , eBottom = availHeight ctx - 1 + , eLeft = 0 + , eRight = availWidth ctx - 1 + } + +renderDynBorder :: DynBorder -> V.Image +renderDynBorder db = V.char (dbAttr db) $ getBorderChar $ dbStyle db + where + getBorderChar = case bsDraw <$> dbSegments db of + -- top bot left right + Edges False False False False -> const ' ' + Edges False False _ _ -> bsHorizontal + Edges _ _ False False -> bsVertical + Edges False True False True -> bsCornerTL + Edges False True True False -> bsCornerTR + Edges True False False True -> bsCornerBL + Edges True False True False -> bsCornerBR + Edges False True True True -> bsIntersectT + Edges True False True True -> bsIntersectB + Edges True True False True -> bsIntersectL + Edges True True True False -> bsIntersectR + Edges True True True True -> bsIntersectFull + +-- | This function provides a simplified interface to rendering a list +-- of 'Widget's as a 'V.Picture' outside of the context of an 'App'. +-- This can be useful in a testing setting but isn't intended to be used +-- for normal application rendering. The API is deliberately narrower +-- than the main interactive API and is not yet stable. Use at your own +-- risk. +-- +-- Consult the [Vty library documentation](https://hackage.haskell.org/package/vty) +-- for details on how to output the resulting 'V.Picture'. +renderWidget :: (Ord n) + => Maybe AttrMap + -- ^ Optional attribute map used to render. If omitted, + -- an empty attribute map with the terminal's default + -- attribute will be used. + -> [Widget n] + -- ^ The widget layers to render, topmost first. + -> V.DisplayRegion + -- ^ The size of the display region in which to render the + -- layers. + -> V.Picture +renderWidget mAttrMap layerRenders region = pic + where + initialRS = RS { viewportMap = M.empty + , rsScrollRequests = [] + , observedNames = S.empty + , renderCache = mempty + , clickableNames = [] + , requestedVisibleNames_ = S.empty + , reportedExtents = mempty + } + am = fromMaybe (attrMap V.defAttr []) mAttrMap + (_, pic, _, _) = renderFinal am layerRenders region (const Nothing) initialRS diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -1,46 +1,100 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} -- | This module provides a scrollable list type and functions for -- manipulating and rendering it. +-- +-- 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'. module Brick.Widgets.List - ( List(listElements, listSelected, listName, listItemHeight) + ( GenericList + , List - -- * Consructing a list + -- * Constructing a list , list -- * Rendering a list , renderList + , renderListWithIndex + -- * Handling events + , handleListEvent + , handleListEventVi + -- * Lenses , listElementsL , listSelectedL , listNameL , listItemHeightL + , listSelectedElementL + -- * Accessors + , listElements + , listName + , listSelectedElement + , listSelected + , listItemHeight + -- * Manipulating a list , listMoveBy , listMoveTo + , listMoveToElement + , listFindBy , listMoveUp , listMoveDown + , listMoveByPages + , listMovePageUp + , listMovePageDown + , listMoveToBeginning + , listMoveToEnd , listInsert , listRemove , listReplace - , listSelectedElement + , listClear + , listReverse + , listModify + -- * Querying a list + , listFindFirst + -- * Attributes , listAttr , listSelectedAttr + , listSelectedFocusedAttr + + -- * Classes + , Splittable(..) + , Reversible(..) ) where -import Control.Applicative ((<$>)) -import Control.Lens ((^.), (&), (.~), _2) -import Data.Monoid ((<>)) +import Prelude hiding (reverse, splitAt) + +import Control.Applicative ((<|>)) +import Data.Foldable (find, toList) +import Control.Monad.State (evalState) + +import Lens.Micro (Traversal', (^.), (^?), (&), (.~), (%~), _2, set) +import Data.Functor (($>)) +import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (fromMaybe) -import qualified Data.Algorithm.Diff as D -import Graphics.Vty (Event(..), Key(..)) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup, (<>)) +#endif +import Data.Semigroup (sconcat) +import qualified Data.Sequence as Seq +import Graphics.Vty (Event(..), Key(..), Modifier(..)) import qualified Data.Vector as V +import GHC.Generics (Generic) import Brick.Types import Brick.Main (lookupViewport) @@ -48,211 +102,593 @@ import Brick.Util (clamp) import Brick.AttrMap --- | List state. Lists have an element type 'e' that is the data stored --- by the list. Lists handle the following events by default: +-- | 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: -- -- * Up/down arrow keys: move cursor of selected item -- * Page up / page down keys: move cursor of selected item by one page -- at a time (based on the number of items shown) -- * Home/end keys: move cursor of selected item to beginning or end of -- list -data List e = - List { listElements :: !(V.Vector e) +-- +-- The 'List' type synonym fixes @t@ to 'V.Vector' for compatibility +-- with previous versions of this library. +-- +-- For a container type to be usable with 'GenericList', it must have +-- instances of 'Traversable' and 'Splittable'. The following functions +-- impose further constraints: +-- +-- * 'listInsert': 'Applicative' and 'Semigroup' +-- * 'listRemove': 'Semigroup' +-- * 'listClear': 'Monoid' +-- * 'listReverse': 'Reversible' +-- +data GenericList n t e = + List { listElements :: !(t e) + -- ^ The list's sequence of elements. , listSelected :: !(Maybe Int) - , listName :: Name + -- ^ The list's selected element index, if any. + , listName :: n + -- ^ The list's name. , listItemHeight :: Int - } + -- ^ The height of an individual item in the list. + } deriving (Functor, Foldable, Traversable, Show, Generic) -suffixLenses ''List +suffixLenses ''GenericList -instance HandleEvent (List e) where - handleEvent e theList = f - where - f = case e of - EvKey KUp [] -> return $ listMoveUp theList - EvKey KDown [] -> return $ listMoveDown theList - EvKey KHome [] -> return $ listMoveTo 0 theList - EvKey KEnd [] -> return $ listMoveTo (V.length $ listElements theList) theList - EvKey KPageDown [] -> do - v <- lookupViewport (theList^.listNameL) - case v of - Nothing -> return theList - Just vp -> return $ listMoveBy (vp^.vpSize._2 `div` theList^.listItemHeightL) theList - EvKey KPageUp [] -> do - v <- lookupViewport (theList^.listNameL) - case v of - Nothing -> return theList - Just vp -> return $ listMoveBy (negate $ vp^.vpSize._2 `div` theList^.listItemHeightL) theList - _ -> return theList +-- | An alias for 'GenericList' specialized to use a 'Vector' as its +-- container type. +type List n e = GenericList n V.Vector e +instance Named (GenericList n t e) n where + getName = listName + +-- | Ordered container types that can be split at a given index. An +-- instance of this class is required for a container type to be usable +-- with 'GenericList'. +class Splittable t where + {-# MINIMAL splitAt #-} + + -- | Split at the given index. Equivalent to @(take n xs, drop n xs)@ + -- and therefore total. + splitAt :: Int -> t a -> (t a, t a) + + -- | Slice the structure. Equivalent to @(take n . drop i) xs@ and + -- therefore total. + -- + -- The default implementation applies 'splitAt' two times: first to + -- drop elements leading up to the slice, and again to drop elements + -- after the slice. + slice :: Int {- ^ start index -} -> Int {- ^ length -} -> t a -> t a + slice i n = fst . splitAt n . snd . splitAt i + +-- | /O(1)/ 'splitAt'. +instance Splittable V.Vector where + splitAt = V.splitAt + +-- | /O(log(min(i,n-i)))/ 'splitAt'. +instance Splittable Seq.Seq where + splitAt = Seq.splitAt + +-- | Ordered container types where the order of elements can be +-- reversed. Only required if you want to use 'listReverse'. +class Reversible t where + {-# MINIMAL reverse #-} + reverse :: t a -> t a + +-- | /O(n)/ 'reverse' +instance Reversible V.Vector where + reverse = V.reverse + +-- | /O(n)/ 'reverse' +instance Reversible Seq.Seq where + reverse = Seq.reverse + +-- | Handle events for list cursor movement. Events handled are: +-- +-- * Up (up arrow key) +-- * Down (down arrow key) +-- * Page Up (PgUp) +-- * Page Down (PgDown) +-- * Go to first element (Home) +-- * Go to last element (End) +handleListEvent :: (Foldable t, Splittable t, Ord n) + => Event + -> EventM n (GenericList n t e) () +handleListEvent e = + case e of + EvKey KUp [] -> modify listMoveUp + EvKey KDown [] -> modify listMoveDown + EvKey KHome [] -> modify listMoveToBeginning + EvKey KEnd [] -> modify listMoveToEnd + EvKey KPageDown [] -> listMovePageDown + EvKey KPageUp [] -> listMovePageUp + _ -> return () + +-- | Enable list movement with the vi keys with a fallback handler if +-- none match. Use 'handleListEventVi' in place of 'handleListEvent' +-- to add the vi keys bindings to the standard ones. Movements handled +-- include: +-- +-- * Up (k) +-- * Down (j) +-- * Page Up (Ctrl-b) +-- * Page Down (Ctrl-f) +-- * Half Page Up (Ctrl-u) +-- * Half Page Down (Ctrl-d) +-- * Go to first element (g) +-- * Go to last element (G) +handleListEventVi :: (Foldable t, Splittable t, Ord n) + => (Event -> EventM n (GenericList n t e) ()) + -- ^ Fallback event handler to use if none of the vi keys + -- match. + -> Event + -> EventM n (GenericList n t e) () +handleListEventVi fallback e = + case e of + EvKey (KChar 'k') [] -> modify listMoveUp + EvKey (KChar 'j') [] -> modify listMoveDown + EvKey (KChar 'g') [] -> modify listMoveToBeginning + EvKey (KChar 'G') [] -> modify listMoveToEnd + EvKey (KChar 'f') [MCtrl] -> listMovePageDown + EvKey (KChar 'b') [MCtrl] -> listMovePageUp + EvKey (KChar 'd') [MCtrl] -> listMoveByPages (0.5::Double) + EvKey (KChar 'u') [MCtrl] -> listMoveByPages (-0.5::Double) + _ -> fallback e + +-- | Move the list selection to the first element in the list. +listMoveToBeginning :: (Foldable t, Splittable t) + => GenericList n t e + -> GenericList n t e +listMoveToBeginning = listMoveTo 0 + +-- | Move the list selection to the last element in the list. +listMoveToEnd :: (Foldable t, Splittable t) + => GenericList n t e + -> GenericList n t e +listMoveToEnd l = listMoveTo (max 0 $ length (listElements l) - 1) l + -- | The top-level attribute used for the entire list. listAttr :: AttrName -listAttr = "list" +listAttr = attrName "list" --- | The attribute used only for the currently-selected list item. --- Extends 'listAttr'. +-- | The attribute used only for the currently-selected list item when +-- the list does not have focus. Extends 'listAttr'. listSelectedAttr :: AttrName -listSelectedAttr = listAttr <> "selected" +listSelectedAttr = listAttr <> attrName "selected" --- | Construct a list in terms of an element type 'e'. -list :: Name +-- | The attribute used only for the currently-selected list item when +-- the list has focus. Extends 'listSelectedAttr'. +listSelectedFocusedAttr :: AttrName +listSelectedFocusedAttr = listSelectedAttr <> attrName "focused" + +-- | Construct a list in terms of container 't' with element type 'e'. +list :: (Foldable t) + => n -- ^ The list name (must be unique) - -> V.Vector e + -> t e -- ^ The initial list contents -> Int -- ^ The list item height in rows (all list item widgets must be - -- this high) - -> List e + -- this high). + -> GenericList n t e list name es h = - let selIndex = if V.null es then Nothing else Just 0 - in List es selIndex name h + let selIndex = if null es then Nothing else Just 0 + safeHeight = max 1 h + in List es selIndex name safeHeight --- | Turn a list state value into a widget given an item drawing --- function. -renderList :: List e -> (Bool -> e -> Widget) -> Widget -renderList l drawElem = +-- | Render a list using the specified item drawing function. +-- +-- Evaluates the underlying container up to, and a bit beyond, the +-- selected element. The exact amount depends on available height +-- for drawing and 'listItemHeight'. At most, it will evaluate up to +-- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the +-- available height. +-- +-- Note that this function renders the list with the 'listAttr' as +-- the default attribute and then uses 'listSelectedAttr' as the +-- default attribute for the selected item if the list is not focused +-- or 'listSelectedFocusedAttr' otherwise. This is provided as a +-- convenience so that the item rendering function doesn't have to be +-- concerned with attributes, but if those attributes are undesirable +-- for your purposes, 'forceAttr' can always be used by the item +-- rendering function to ensure that another attribute is used instead. +renderList :: (Traversable t, Splittable t, Ord n, Show n) + => (Bool -> e -> Widget n) + -- ^ Rendering function, True for the selected element + -> Bool + -- ^ Whether the list has focus + -> GenericList n t e + -- ^ The List to be rendered + -> Widget n + -- ^ rendered widget +renderList drawElem = renderListWithIndex $ const drawElem + +-- | Like 'renderList', except the render function is also provided with +-- the index of each element. +-- +-- Has the same evaluation characteristics as 'renderList'. +renderListWithIndex :: (Traversable t, Splittable t, Ord n, Show n) + => (Int -> Bool -> e -> Widget n) + -- ^ Rendering function, taking index, and True for + -- the selected element + -> Bool + -- ^ Whether the list has focus + -> GenericList n t e + -- ^ The List to be rendered + -> Widget n + -- ^ rendered widget +renderListWithIndex drawElem foc l = withDefAttr listAttr $ - drawListElements l drawElem + drawListElements foc l drawElem -drawListElements :: List e -> (Bool -> e -> Widget) -> Widget -drawListElements l drawElem = +imap :: (Traversable t) => (Int -> a -> b) -> t a -> t b +imap f xs = + let act = traverse (\a -> get >>= \i -> put (i + 1) $> f i a) xs + in evalState act 0 + +-- | Draws the list elements. +-- +-- Evaluates the underlying container up to, and a bit beyond, the +-- selected element. The exact amount depends on available height +-- for drawing and 'listItemHeight'. At most, it will evaluate up to +-- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the +-- available height. +drawListElements :: (Traversable t, Splittable t, Ord n, Show n) + => Bool + -> GenericList n t e + -> (Int -> Bool -> e -> Widget n) + -> Widget n +drawListElements foc l drawElem = Widget Greedy Greedy $ do c <- getContext - let es = V.slice start num (l^.listElementsL) - idx = case l^.listSelectedL of - Nothing -> 0 - Just i -> i + -- Take (numPerHeight * 2) elements, or whatever is left + let es = slice start (numPerHeight * 2) (l^.listElementsL) + idx = fromMaybe 0 (l^.listSelectedL) + start = max 0 $ idx - numPerHeight + 1 - num = min (numPerHeight * 2) (V.length (l^.listElementsL) - start) - numPerHeight = (c^.availHeightL) `div` (l^.listItemHeightL) + -- The number of items to show is the available height + -- divided by the item height... + initialNumPerHeight = (c^.availHeightL) `div` (l^.listItemHeightL) + -- ... but if the available height leaves a remainder of + -- an item height then we need to ensure that we render an + -- extra item to show a partial item at the top or bottom to + -- give the expected result when an item is more than one + -- row high. (Example: 5 rows available with item height + -- of 3 yields two items: one fully rendered, the other + -- rendered with only its top 2 or bottom 2 rows visible, + -- depending on how the viewport state changes.) + numPerHeight = initialNumPerHeight + + if initialNumPerHeight * (l^.listItemHeightL) == c^.availHeightL + then 0 + else 1 + off = start * (l^.listItemHeightL) - drawnElements = (flip V.imap) es $ \i e -> - let isSelected = Just (i + start) == l^.listSelectedL - elemWidget = drawElem isSelected e + drawnElements = flip imap es $ \i e -> + let j = i + start + isSelected = Just j == l^.listSelectedL + elemWidget = drawElem j isSelected e + selItemAttr = if foc + then withDefAttr listSelectedFocusedAttr + else withDefAttr listSelectedAttr makeVisible = if isSelected - then (visible . withDefAttr listSelectedAttr) + then visible . selItemAttr else id in makeVisible elemWidget render $ viewport (l^.listNameL) Vertical $ translateBy (Location (0, off)) $ - vBox $ V.toList drawnElements + vBox $ toList drawnElements -- | Insert an item into a list at the specified position. -listInsert :: Int +-- +-- Complexity: the worse of 'splitAt' and `<>` for the container type. +-- +-- @ +-- listInsert for 'List': O(n) +-- listInsert for 'Seq.Seq': O(log(min(i, length n - i))) +-- @ +listInsert :: (Splittable t, Applicative t, Semigroup (t e)) + => Int -- ^ The position at which to insert (0 <= i <= size) -> e -- ^ The element to insert - -> List e - -> List e + -> GenericList n t e + -> GenericList n t e listInsert pos e l = - let safePos = clamp 0 (V.length es) pos - es = l^.listElementsL + let es = l^.listElementsL newSel = case l^.listSelectedL of - Nothing -> 0 - Just s -> if safePos < s - then s + 1 - else s - (front, back) = V.splitAt safePos es + Nothing -> 0 + Just s -> if pos <= s + then s + 1 + else s + (front, back) = splitAt pos es in l & listSelectedL .~ Just newSel - & listElementsL .~ (front V.++ (e `V.cons` back)) + & listElementsL .~ sconcat (front :| [pure e, back]) -- | Remove an element from a list at the specified position. -listRemove :: Int - -- ^ The position at which to remove an element (0 <= i < size) - -> List e - -> List e -listRemove pos l | V.null (l^.listElementsL) = l - | pos /= clamp 0 (V.length (l^.listElementsL) - 1) pos = l +-- +-- Applies 'splitAt' two times: first to split the structure at the +-- given position, and again to remove the first element from the tail. +-- Consider the asymptotics of `splitAt` for the container type when +-- using this function. +-- +-- Complexity: the worse of 'splitAt' and `<>` for the container type. +-- +-- @ +-- listRemove for 'List': O(n) +-- listRemove for 'Seq.Seq': O(log(min(i, n - i))) +-- @ +listRemove :: (Splittable t, Foldable t, Semigroup (t e)) + => Int + -- ^ The position at which to remove an element (0 <= i < + -- size) + -> GenericList n t e + -> GenericList n t e +listRemove pos l | null l = l + | pos /= splitClamp l pos = l | otherwise = let newSel = case l^.listSelectedL of - Nothing -> 0 - Just s -> if pos == 0 - then 0 - else if pos == s - then pos - 1 - else if pos < s - then s - 1 - else s - (front, back) = V.splitAt pos es - es' = front V.++ V.tail back + Nothing -> 0 + Just s | pos == 0 -> 0 + | pos == s -> pos - 1 + | pos < s -> s - 1 + | otherwise -> s + (front, rest) = splitAt pos es + (_, back) = splitAt 1 rest + es' = front <> back es = l^.listElementsL - in l & listSelectedL .~ (if V.null es' then Nothing else Just newSel) + in l & listSelectedL .~ (if null es' then Nothing else Just newSel) & listElementsL .~ es' --- | Replace the contents of a list with a new set of elements but --- preserve the currently selected index. -listReplace :: Eq e => V.Vector e -> List e -> List e -listReplace es' l | es' == l^.listElementsL = l - | otherwise = - let sel = fromMaybe 0 (l^.listSelectedL) - getNewSel es = case (V.null es, V.null es') of - (_, True) -> Nothing - (True, False) -> Just 0 - (False, False) -> Just (maintainSel (V.toList es) (V.toList es') sel) - newSel = getNewSel (l^.listElementsL) - - in l & listSelectedL .~ newSel - & listElementsL .~ es' +-- | Replace the contents of a list with a new set of elements and +-- update the new selected index. If the list is empty, empty selection +-- is used instead. Otherwise, if the specified selected index (via +-- 'Just') is not in the list bounds, zero is used instead. +-- +-- Complexity: same as 'splitAt' for the container type. +listReplace :: (Foldable t, Splittable t) + => t e + -> Maybe Int + -> GenericList n t e + -> GenericList n t e +listReplace es idx l = + let l' = l & listElementsL .~ es + newSel = if null es then Nothing else inBoundsOrZero <$> idx + inBoundsOrZero i + | i == splitClamp l' i = i + | otherwise = 0 + in l' & listSelectedL .~ newSel -- | Move the list selected index up by one. (Moves the cursor up, -- subtracts one from the index.) -listMoveUp :: List e -> List e +listMoveUp :: (Foldable t, Splittable t) + => GenericList n t e + -> GenericList n t e listMoveUp = listMoveBy (-1) +-- | Move the list selected index up by one page. +listMovePageUp :: (Foldable t, Splittable t, Ord n) + => 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.) -listMoveDown :: List e -> List e +listMoveDown :: (Foldable t, Splittable t) + => GenericList n t e + -> GenericList n t e listMoveDown = listMoveBy 1 --- | Move the list selected index by the specified amount, subject to --- validation. -listMoveBy :: Int -> List e -> List e +-- | Move the list selected index down by one page. +listMovePageDown :: (Foldable t, Splittable t, Ord n) + => EventM n (GenericList n t e) () +listMovePageDown = listMoveByPages (1::Double) + +-- | Move the list selected index by some (fractional) number of pages. +listMoveByPages :: (Foldable t, Splittable t, Ord n, RealFrac m) + => m + -> EventM n (GenericList n t e) () +listMoveByPages pages = do + theList <- get + v <- lookupViewport (theList^.listNameL) + case v of + Nothing -> return () + Just vp -> do + let nElems = round $ pages * fromIntegral (vp^.vpSize._2) / + fromIntegral (theList^.listItemHeightL) + modify $ listMoveBy nElems + +-- | 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"). +-- +-- If the current selection is @Nothing@ (i.e. there is no selection) +-- and the direction is positive, set to @Just 0@ (first element), +-- otherwise set to @Just (length - 1)@ (last element). +-- +-- Complexity: same as 'splitAt' for the container type. +-- +-- @ +-- listMoveBy for 'List': O(1) +-- listMoveBy for 'Seq.Seq': O(log(min(i,n-i))) +-- @ +listMoveBy :: (Foldable t, Splittable t) + => Int + -> GenericList n t e + -> GenericList n t e listMoveBy amt l = - let newSel = clamp 0 (V.length (l^.listElementsL) - 1) <$> (amt +) <$> (l^.listSelectedL) - in l & listSelectedL .~ newSel + let target = case l ^. listSelectedL of + Nothing + | amt > 0 -> 0 + | otherwise -> length l - 1 + Just i -> max 0 (amt + i) -- don't be negative + in listMoveTo target l -- | Set the selected index for a list to the specified index, subject -- to validation. -listMoveTo :: Int -> List e -> List e +-- +-- If @pos >= 0@, indexes from the start of the list (which gets +-- evaluated up to the target index) +-- +-- If @pos < 0@, indexes from the end of the list (which evaluates +-- 'length' of the list). +-- +-- Complexity: same as 'splitAt' for the container type. +-- +-- @ +-- listMoveTo for 'List': O(1) +-- listMoveTo for 'Seq.Seq': O(log(min(i,n-i))) +-- @ +listMoveTo :: (Foldable t, Splittable t) + => Int + -> GenericList n t e + -> GenericList n t e listMoveTo pos l = - let len = V.length (l^.listElementsL) - newSel = clamp 0 (len - 1) $ if pos < 0 then (len - pos) else pos - in l & listSelectedL .~ if len > 0 - then Just newSel - else Nothing + let len = length l + i = if pos < 0 then len - pos else pos + newSel = splitClamp l i + in l & listSelectedL .~ if null l then Nothing else Just newSel --- | Return a list's selected element, if any. -listSelectedElement :: List e -> Maybe (Int, e) -listSelectedElement l = do - sel <- l^.listSelectedL - return (sel, (l^.listElementsL) V.! sel) +-- | Split-based clamp that avoids evaluating 'length' of the structure +-- (unless the structure is already fully evaluated). +splitClamp :: (Foldable t, Splittable t) => GenericList n t e -> Int -> Int +splitClamp l i = + let (_, t) = splitAt i (l ^. listElementsL) -- split at i + in + -- If the tail is empty, then the requested index is not in the + -- list. And because we have already seen the end of the list, + -- using 'length' will not force unwanted computation. + -- + -- Otherwise if tail is not empty, then we already know that i + -- is in the list, so we don't need to know the length + clamp 0 (if null t then length l - 1 else i) i --- Assuming `xs` is an existing list that we want to update to match the --- state of `ys`. Given a selected index in `xs`, the goal is to compute --- the corresponding index in `ys`. -maintainSel :: (Eq e) => [e] -> [e] -> Int -> Int -maintainSel xs ys sel = let hunks = D.getDiff xs ys - in merge 0 sel hunks +-- | Set the selected index for a list to the index of the first +-- occurrence of the specified element if it is in the list, or leave +-- the list unmodified otherwise. +-- +-- /O(n)/. Only evaluates as much of the container as needed. +listMoveToElement :: (Eq e, Foldable t, Splittable t) + => e + -> GenericList n t e + -> GenericList n t e +listMoveToElement e = listFindBy (== e) . set listSelectedL Nothing -merge :: (Eq e) => Int -> Int -> [D.Diff e] -> Int -merge _ sel [] = sel -merge idx sel (h:hs) | idx > sel = sel - | otherwise = case h of - D.Both _ _ -> merge sel (idx + 1) hs +-- | 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 - -- element removed in new list - D.First _ -> let newSel = if idx < sel - then sel - 1 - else sel - in merge newSel idx hs +-- | 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 +-- at all, the search starts at the beginning. If no matching element is +-- found anywhere in the list, leave the list unmodified. +-- +-- /O(n)/. Only evaluates as much of the container as needed. +listFindBy :: (Foldable t, Splittable t) + => (e -> Bool) + -> GenericList n t e + -> GenericList n t e +listFindBy test l = + let start = maybe 0 (+1) (l ^. listSelectedL) + (h, t) = splitAt start (l ^. listElementsL) + tailResult = find (test . snd) . zip [start..] . toList $ t + headResult = find (test . snd) . zip [0..] . toList $ h + result = tailResult <|> headResult + in maybe id (set listSelectedL . Just . fst) result l - -- element added in new list - D.Second _ -> let newSel = if idx <= sel - then sel + 1 - else sel - in merge newSel (idx + 1) hs +-- | Traversal that targets the selected element, if any. +-- +-- Complexity: depends on usage as well as the list's container type. +-- +-- @ +-- listSelectedElementL for 'List': O(1) -- preview, fold +-- O(n) -- set, modify, traverse +-- listSelectedElementL for 'Seq.Seq': O(log(min(i, n - i))) -- all operations +-- @ +-- +listSelectedElementL :: (Splittable t, Traversable t, Semigroup (t e)) + => Traversal' (GenericList n t e) e +listSelectedElementL f l = + case l ^. listSelectedL of + Nothing -> pure l + Just i -> listElementsL go l + where + go l' = let (left, rest) = splitAt i l' + -- middle contains the target element (if any) + (middle, right) = splitAt 1 rest + in (\m -> left <> m <> right) <$> (traverse f middle) + +-- | Return a list's selected element, if any. +-- +-- Only evaluates as much of the container as needed. +-- +-- Complexity: same as 'splitAt' for the container type. +-- +-- @ +-- listSelectedElement for 'List': O(1) +-- listSelectedElement for 'Seq.Seq': O(log(min(i, n - i))) +-- @ +listSelectedElement :: (Splittable t, Traversable t, Semigroup (t e)) + => GenericList n t e + -> Maybe (Int, e) +listSelectedElement l = + (,) <$> l^.listSelectedL <*> l^?listSelectedElementL + +-- | Remove all elements from the list and clear the selection. +-- +-- /O(1)/ +listClear :: (Monoid (t e)) => GenericList n t e -> GenericList n t e +listClear l = l & listElementsL .~ mempty & listSelectedL .~ Nothing + +-- | Reverse the list. The element selected before the reversal will +-- again be the selected one. +-- +-- Complexity: same as 'reverse' for the container type. +-- +-- @ +-- listReverse for 'List': O(n) +-- listReverse for 'Seq.Seq': O(n) +-- @ +listReverse :: (Reversible t, Foldable t) + => GenericList n t e + -> GenericList n t e +listReverse l = + 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. +-- +-- Complexity: same as 'traverse' for the container type (typically +-- /O(n)/). +-- +-- Complexity: same as 'listSelectedElementL' for the list's container type. +-- +-- @ +-- listModify for 'List': O(n) +-- listModify for 'Seq.Seq': O(log(min(i, n - i))) +-- @ +-- +listModify :: (Traversable t, Splittable t, Semigroup (t e)) + => (e -> e) + -> GenericList n t e + -> GenericList n t e +listModify f = listSelectedElementL %~ f diff --git a/src/Brick/Widgets/ProgressBar.hs b/src/Brick/Widgets/ProgressBar.hs --- a/src/Brick/Widgets/ProgressBar.hs +++ b/src/Brick/Widgets/ProgressBar.hs @@ -1,15 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | This module provides a progress bar widget. module Brick.Widgets.ProgressBar ( progressBar + , customProgressBar -- * Attributes , progressCompleteAttr , progressIncompleteAttr ) where -import Control.Lens ((^.)) +import Lens.Micro ((^.)) +import Data.Maybe (fromMaybe) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid +#endif +import Graphics.Vty (safeWcswidth) import Brick.Types import Brick.AttrMap @@ -17,11 +23,11 @@ -- | The attribute of the completed portion of the progress bar. progressCompleteAttr :: AttrName -progressCompleteAttr = "progressComplete" +progressCompleteAttr = attrName "progressComplete" -- | The attribute of the incomplete portion of the progress bar. progressIncompleteAttr :: AttrName -progressIncompleteAttr = "progressIncomplete" +progressIncompleteAttr = attrName "progressIncomplete" -- | Draw a progress bar with the specified (optional) label and -- progress value. This fills available horizontal space and is one row @@ -31,19 +37,48 @@ -- the progress bar. -> Float -- ^ The progress value. Should be between 0 and 1 inclusive. - -> Widget -progressBar mLabel progress = + -> Widget n +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/master/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 = maybe "" id mLabel - labelWidth = length label + label = fromMaybe "" mLabel + labelWidth = safeWcswidth label spacesWidth = barWidth - labelWidth - leftPart = replicate (spacesWidth `div` 2) ' ' - rightPart = replicate (barWidth - (labelWidth + length leftPart)) ' ' - fullBar = leftPart <> label <> rightPart + leftWidth = spacesWidth `div` 2 + rightWidth = barWidth - labelWidth - leftWidth completeWidth = round $ progress * toEnum barWidth - completePart = take completeWidth fullBar - incompletePart = drop completeWidth fullBar + + 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 + adjustedCompleteWidth = if completeWidth == length fullBar && progress < 1.0 + then completeWidth - 1 + else if completeWidth == 0 && progress > 0.0 + then 1 + else completeWidth + (completePart, incompletePart) = splitAt adjustedCompleteWidth fullBar render $ (withAttr progressCompleteAttr $ str completePart) <+> (withAttr progressIncompleteAttr $ str incompletePart) diff --git a/src/Brick/Widgets/Table.hs b/src/Brick/Widgets/Table.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Table.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE MultiWayIf #-} +-- | This module provides a table widget that can draw other widgets +-- in a table layout, draw borders between rows and columns, and allow +-- configuration of row and column alignment. To get started, see +-- 'table'. +module Brick.Widgets.Table + ( + -- * Types + Table + , ColumnAlignment(..) + , RowAlignment(..) + , TableException(..) + + -- * Construction + , table + + -- * Configuration + , alignLeft + , alignRight + , alignCenter + , alignTop + , alignMiddle + , alignBottom + , setColAlignment + , setRowAlignment + , setDefaultColAlignment + , setDefaultRowAlignment + , surroundingBorder + , rowBorders + , columnBorders + + -- * Rendering + , renderTable + + -- * Low-level API + , RenderedTableCells(..) + , BorderConfiguration(..) + , tableCellLayout + , addBorders + , alignColumns + ) +where + +import Control.Monad (forM) +import qualified Control.Exception as E +import Data.List (transpose, intersperse, nub) +import qualified Data.Map as M +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import Graphics.Vty (imageHeight, imageWidth, charFill) +import Lens.Micro ((^.)) + +import Brick.Types +import Brick.Widgets.Core +import Brick.Widgets.Center +import Brick.Widgets.Border + +-- | Column alignment modes. Use these modes with the alignment +-- functions in this module to configure column alignment behavior. +data ColumnAlignment = + AlignLeft + -- ^ Align all cells to the left. + | AlignCenter + -- ^ Center the content horizontally in all cells in the column. + | AlignRight + -- ^ Align all cells to the right. + deriving (Eq, Show, Read) + +-- | Row alignment modes. Use these modes with the alignment functions +-- in this module to configure row alignment behavior. +data RowAlignment = + AlignTop + -- ^ Align all cells to the top. + | AlignMiddle + -- ^ Center the content vertically in all cells in the row. + | AlignBottom + -- ^ Align all cells to the bottom. + deriving (Eq, Show, Read) + +-- | A table creation exception. +data TableException = + TEUnequalRowSizes + -- ^ Rows did not all have the same number of cells. + | TEInvalidCellSizePolicy + -- ^ Some cells in the table did not use the 'Fixed' size policy for + -- both horizontal and vertical sizing. + deriving (Eq, Show, Read) + +instance E.Exception TableException where + +-- | A table data structure for widgets of type 'Widget' @n@. Create a +-- table with 'table'. +data Table n = + Table { columnAlignments :: M.Map Int ColumnAlignment + , rowAlignments :: M.Map Int RowAlignment + , tableRows :: [[Widget n]] + , defaultColumnAlignment :: ColumnAlignment + , defaultRowAlignment :: RowAlignment + , tableBorderConfiguration :: BorderConfiguration + } + +-- | A border configuration for a table. +data BorderConfiguration = + BorderConfiguration { drawSurroundingBorder :: Bool + , drawRowBorders :: Bool + , drawColumnBorders :: Bool + } + +-- | Construct a new table. +-- +-- The argument is the list of rows with the topmost row first, with +-- each element of the argument list being the contents of the cells in +-- in each column of the respective row, with the leftmost cell first. +-- +-- Each row's height is determined by the height of the tallest cell +-- in that row, and each column's width is determined by the width of +-- the widest cell in that column. This means that control over row +-- and column dimensions is a matter of controlling the size of the +-- individual cells, such as by wrapping cell contents in padding, +-- 'fill' and 'hLimit' or 'vLimit', etc. This also means that it is not +-- necessary to explicitly set the width of most table cells because +-- the table will determine the per-row and per-column dimensions by +-- looking at the largest cell contents. In particular, this means +-- that the table's alignment logic only has an effect when a given +-- cell's contents are smaller than the maximum for its row and column, +-- thus giving the table some way to pad the contents to result in the +-- desired alignment. +-- +-- By default: +-- +-- * All columns are left-aligned. Use the alignment functions in this +-- module to change that behavior. +-- * All rows are top-aligned. Use the alignment functions in this +-- module to change that behavior. +-- * The table will draw borders between columns, between rows, and +-- around the outside of the table. Border-drawing behavior can be +-- configured with the API in this module. Note that tables always draw +-- with 'joinBorders' enabled. If a cell's contents has smart borders +-- but you don't want those borders to connect to the surrounding table +-- borders, wrap the cell's contents with 'freezeBorders'. +-- +-- All cells of all rows MUST use the 'Fixed' growth policy for both +-- horizontal and vertical growth. If the argument list contains any +-- cells that use the 'Greedy' policy, this function will raise a +-- 'TableException'. +-- +-- All rows MUST have the same number of cells. If not, this function +-- will raise a 'TableException'. +table :: [[Widget n]] -> Table n +table rows = + if | not allFixed -> E.throw TEInvalidCellSizePolicy + | not allSameLength -> E.throw TEUnequalRowSizes + | otherwise -> t + where + allSameLength = length (nub (length <$> rows)) <= 1 + allFixed = all fixedRow rows + fixedRow = all fixedCell + fixedCell w = hSize w == Fixed && vSize w == Fixed + t = Table { columnAlignments = mempty + , rowAlignments = mempty + , tableRows = rows + , defaultColumnAlignment = AlignLeft + , defaultRowAlignment = AlignTop + , tableBorderConfiguration = + BorderConfiguration { drawSurroundingBorder = True + , drawRowBorders = True + , drawColumnBorders = True + } + } + +-- | Configure whether the table draws a border on its exterior. +surroundingBorder :: Bool -> Table n -> Table n +surroundingBorder b t = + t { tableBorderConfiguration = (tableBorderConfiguration t) { drawSurroundingBorder = b } } + +-- | Configure whether the table draws borders between its rows. +rowBorders :: Bool -> Table n -> Table n +rowBorders b t = + t { tableBorderConfiguration = (tableBorderConfiguration t) { drawRowBorders = b } } + +-- | Configure whether the table draws borders between its columns. +columnBorders :: Bool -> Table n -> Table n +columnBorders b t = + t { tableBorderConfiguration = (tableBorderConfiguration t) { drawColumnBorders = b } } + +-- | Align the specified column to the right. The argument is the column +-- index, starting with zero. Silently does nothing if the index is out +-- of range. +alignRight :: Int -> Table n -> Table n +alignRight = setColAlignment AlignRight + +-- | Align the specified column to the left. The argument is the column +-- index, starting with zero. Silently does nothing if the index is out +-- of range. +alignLeft :: Int -> Table n -> Table n +alignLeft = setColAlignment AlignLeft + +-- | Align the specified column to center. The argument is the column +-- index, starting with zero. Silently does nothing if the index is out +-- of range. +alignCenter :: Int -> Table n -> Table n +alignCenter = setColAlignment AlignCenter + +-- | Align the specified row to the top. The argument is the row index, +-- starting with zero. Silently does nothing if the index is out of +-- range. +alignTop :: Int -> Table n -> Table n +alignTop = setRowAlignment AlignTop + +-- | Align the specified row to the middle. The argument is the row +-- index, starting with zero. Silently does nothing if the index is out +-- of range. +alignMiddle :: Int -> Table n -> Table n +alignMiddle = setRowAlignment AlignMiddle + +-- | Align the specified row to bottom. The argument is the row index, +-- starting with zero. Silently does nothing if the index is out of +-- range. +alignBottom :: Int -> Table n -> Table n +alignBottom = setRowAlignment AlignBottom + +-- | Set the alignment for the specified column index (starting at +-- zero). Silently does nothing if the index is out of range. +setColAlignment :: ColumnAlignment -> Int -> Table n -> Table n +setColAlignment a col t = + t { columnAlignments = M.insert col a (columnAlignments t) } + +-- | Set the alignment for the specified row index (starting at +-- zero). Silently does nothing if the index is out of range. +setRowAlignment :: RowAlignment -> Int -> Table n -> Table n +setRowAlignment a row t = + t { rowAlignments = M.insert row a (rowAlignments t) } + +-- | Set the default column alignment for columns with no explicitly +-- configured alignment. +setDefaultColAlignment :: ColumnAlignment -> Table n -> Table n +setDefaultColAlignment a t = + t { defaultColumnAlignment = a } + +-- | Set the default row alignment for rows with no explicitly +-- configured alignment. +setDefaultRowAlignment :: RowAlignment -> Table n -> Table n +setDefaultRowAlignment a t = + t { defaultRowAlignment = a } + +-- | Render the table. +renderTable :: Table n -> Widget n +renderTable t = + joinBorders $ + Widget Fixed Fixed $ do + tableCellLayout t >>= addBorders >>= render + +-- | The result of performing table cell intermediate rendering and +-- layout. +data RenderedTableCells n = + RenderedTableCells { renderedTableRows :: [[Widget n]] + -- ^ The table's cells in row-major order. + , renderedTableColumnWidths :: [Int] + -- ^ The widths of the table's columns. + , renderedTableRowHeights :: [Int] + -- ^ The heights of the table's rows. + , borderConfiguration :: BorderConfiguration + -- ^ The border configuration to use. + } + +-- | Augment rendered table cells with borders according to the +-- border configuration accompanying the cells. +addBorders :: RenderedTableCells n -> RenderM n (Widget n) +addBorders r = do + let cfg = borderConfiguration r + rows = renderedTableRows r + rowHeights = renderedTableRowHeights r + colWidths = renderedTableColumnWidths r + + contentWidth = sum colWidths + contentHeight = sum rowHeights + + hBorderLength = contentWidth + if drawColumnBorders cfg + then max (length colWidths - 1) 0 + else 0 + vBorderHeight = contentHeight + if drawRowBorders cfg + then max (length rowHeights - 1) 0 + else 0 + horizBorder = hLimit hBorderLength hBorder + vertBorder = vLimit vBorderHeight vBorder + + leftBorder = + vBox [topLeftCorner, vertBorder, bottomLeftCorner] + rightBorder = + vBox [topRightCorner, vertBorder, bottomRightCorner] + + maybeWrap check f = + if check cfg then f else id + addSurroundingBorder b = + leftBorder <+> (horizBorder <=> b <=> horizBorder) <+> rightBorder + addRowBorders = + intersperse horizBorder + + rowsWithColumnBorders = (\(h, row) -> hBox $ maybeColumnBorders h row) <$> zip rowHeights rows + maybeColumnBorders height = maybeIntersperse cfg drawColumnBorders (vLimit height vBorder) + body = vBox $ + maybeWrap drawRowBorders addRowBorders rowsWithColumnBorders + + return $ maybeWrap drawSurroundingBorder addSurroundingBorder body + +tableCellLayout :: Table n -> RenderM n (RenderedTableCells n) +tableCellLayout t = do + ctx <- getContext + cellResults <- forM (tableRows t) $ mapM render + + let rowHeights = rowHeight <$> cellResults + colWidths = colWidth <$> transpose cellResults + numRows = length rowHeights + numCols = if length cellResults >= 1 + then length (cellResults !! 0) + else 0 + allRowAligns = (\i -> M.findWithDefault (defaultRowAlignment t) i (rowAlignments t)) <$> + [0..numRows - 1] + allColAligns = (\i -> M.findWithDefault (defaultColumnAlignment t) i (columnAlignments t)) <$> + [0..numCols - 1] + rowHeight = maximum . fmap (imageHeight . image) + colWidth = maximum . fmap (imageWidth . image) + + toW = Widget Fixed Fixed . return + fillEmptyCell w h result = + if imageWidth (image result) == 0 && imageHeight (image result) == 0 + then result { image = charFill (ctx^.attrL) ' ' w h } + else result + mkRow (vAlign, height, rowCells) = + let paddedCells = flip map (zip3 allColAligns colWidths rowCells) $ \(hAlign, width, cell) -> + applyColAlignment width hAlign $ + applyRowAlignment height vAlign $ + toW $ + fillEmptyCell width height cell + in paddedCells + + let rows = mkRow <$> zip3 allRowAligns rowHeights cellResults + + return $ RenderedTableCells { renderedTableRows = rows + , renderedTableColumnWidths = colWidths + , renderedTableRowHeights = rowHeights + , borderConfiguration = tableBorderConfiguration t + } + +maybeIntersperse :: BorderConfiguration -> (BorderConfiguration -> Bool) -> Widget n -> [Widget n] -> [Widget n] +maybeIntersperse cfg f v | f cfg = intersperse v + | otherwise = id + +topLeftCorner :: Widget n +topLeftCorner = joinableBorder $ Edges False True False True + +topRightCorner :: Widget n +topRightCorner = joinableBorder $ Edges False True True False + +bottomLeftCorner :: Widget n +bottomLeftCorner = joinableBorder $ Edges True False False True + +bottomRightCorner :: Widget n +bottomRightCorner = joinableBorder $ Edges True False True False + +-- | Given a "table row" of widgets, align each one according to the +-- list of specified column alignments in columns of the specified +-- widths. +alignColumns :: [ColumnAlignment] + -- ^ The column alignments to use for each widget, + -- respectively. + -> [Int] + -- ^ The width of each column in terminal columns, + -- respectively. + -> [Widget n] + -- ^ The column cells to align. + -> [Widget n] +alignColumns as widths cells = + (\(w, a, c) -> applyColAlignment w a c) <$> zip3 widths as cells + +applyColAlignment :: Int -> ColumnAlignment -> Widget n -> Widget n +applyColAlignment width align w = + hLimit width $ case align of + AlignLeft -> padRight Max w + AlignCenter -> hCenter w + AlignRight -> padLeft Max w + +applyRowAlignment :: Int -> RowAlignment -> Widget n -> Widget n +applyRowAlignment rHeight align w = + vLimit rHeight $ case align of + AlignTop -> padBottom Max w + AlignMiddle -> vCenter w + AlignBottom -> padTop Max w diff --git a/src/Data/IMap.hs b/src/Data/IMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/IMap.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +module Data.IMap + ( IMap + , Run(..) + , empty + , Data.IMap.null + , singleton + , insert + , delete + , restrict + , lookup + , splitLE + , intersectionWith + , mapMaybe + , addToKeys + , unsafeUnion + , fromList + , unsafeRuns + , unsafeToAscList + ) where + +import Data.List (foldl') +import Data.Monoid +import Data.IntMap.Strict (IntMap) +import GHC.Generics +import Control.DeepSeq +import Prelude hiding (lookup) +import qualified Data.IntMap.Strict as IM + +-- | Semantically, 'IMap' and 'IntMap' are identical; but 'IMap' is more +-- efficient when large sequences of contiguous keys are mapped to the same +-- value. +newtype IMap a = IMap { _runs :: IntMap (Run a) } deriving (Show, Functor, Read, Generic, NFData) + +{-# INLINE unsafeRuns #-} +-- | This function is unsafe because 'IMap's that compare equal may split their +-- runs into different chunks; consumers must promise that they do not treat +-- run boundaries specially. +unsafeRuns :: IMap a -> IntMap (Run a) +unsafeRuns = _runs + +instance Eq a => Eq (IMap a) where + IMap m == IMap m' = go (IM.toAscList m) (IM.toAscList m') where + go ((k, Run n a):kvs) ((k', Run n' a'):kvs') + = k == k' && a == a' && case compare n n' of + LT -> go kvs ((k'+n, Run (n'-n) a'):kvs') + EQ -> go kvs kvs' + GT -> go ((k+n', Run (n-n') a):kvs) kvs' + go [] [] = True + go _ _ = False + +instance Ord a => Ord (IMap a) where + compare (IMap m) (IMap m') = go (IM.toAscList m) (IM.toAscList m') where + go [] [] = EQ + go [] _ = LT + go _ [] = GT + go ((k, Run n a):kvs) ((k', Run n' a'):kvs') + = compare k k' <> compare a a' <> case compare n n' of + LT -> go kvs ((k'+n, Run (n'-n) a'):kvs') + EQ -> go kvs kvs' + GT -> go ((k+n', Run (n-n') a):kvs) kvs' + +-- | Zippy: '(<*>)' combines values at equal keys, discarding any values whose +-- key is in only one of its two arguments. +instance Applicative IMap where + pure a = IMap . IM.fromDistinctAscList $ + [ (minBound, Run maxBound a) + , (-1, Run maxBound a) + , (maxBound-1, Run 2 a) + ] + (<*>) = intersectionWith ($) + +-- | @Run n a@ represents @n@ copies of the value @a@. +data Run a = Run + { len :: !Int + , val :: !a + } deriving (Eq, Ord, Read, Show, Functor, Generic, NFData) + +instance Foldable Run where foldMap f r = f (val r) +instance Traversable Run where sequenceA (Run n v) = Run n <$> v + +empty :: IMap a +empty = IMap IM.empty + +null :: IMap a -> Bool +null = IM.null . _runs + +singleton :: Int -> Run a -> IMap a +singleton k r + | len r >= 1 = IMap (IM.singleton k r) + | otherwise = empty + +insert :: Int -> Run a -> IMap a -> IMap a +insert k r m + | len r < 1 = m + | otherwise = m { _runs = IM.insert k r (_runs (delete k r m)) } + +{-# INLINE delete #-} +delete :: Int -> Run ignored -> IMap a -> IMap a +delete k r m + | len r < 1 = m + | otherwise = m { _runs = IM.union (_runs lt) (_runs gt) } + where + (lt, ge) = splitLE (k-1) m + (_ , gt) = splitLE (k+len r-1) ge + +-- | Given a range of keys (as specified by a starting key and a length for +-- consistency with other functions in this module), restrict the map to keys +-- in that range. @restrict k r m@ is equivalent to @intersectionWith const m +-- (insert k r empty)@ but potentially more efficient. +restrict :: Int -> Run ignored -> IMap a -> IMap a +restrict k r = id + . snd + . splitLE (k-1) + . fst + . splitLE (k+len r-1) + +lookup :: Int -> IMap a -> Maybe a +lookup k m = case IM.lookupLE k (_runs m) of + Just (k', Run n a) | k < k'+n -> Just a + _ -> Nothing + +-- | @splitLE n m@ produces a tuple @(le, gt)@ where @le@ has all the +-- associations of @m@ where the keys are @<= n@ and @gt@ has all the +-- associations of @m@ where the keys are @> n@. +splitLE :: Int -> IMap a -> (IMap a, IMap a) +splitLE k m = case IM.lookupLE k (_runs m) of + Nothing -> (empty, m) + Just (k', r@(Run n _)) -> case (k' + n - 1 <= k, k' == k) of + (True , False) -> (m { _runs = lt }, m { _runs = gt }) + (True , True ) -> (m { _runs = IM.insert k r lt }, m { _runs = gt }) + (False, _ ) -> ( m { _runs = IM.insert k' r { len = 1 + k - k' } lt' } + , m { _runs = IM.insert (k+1) r { len = n - 1 - k + k' } gt' } + ) + where + (lt', gt') = IM.split k' (_runs m) + where + (lt, gt) = IM.split k (_runs m) + +-- | Increment all keys by the given amount. This is like +-- 'IM.mapKeysMonotonic', but restricted to partially-applied addition. +addToKeys :: Int -> IMap a -> IMap a +addToKeys n m = m { _runs = IM.mapKeysMonotonic (n+) (_runs m) } + +-- TODO: This is pretty inefficient. IntMap offers some splitting functions +-- that should make it possible to be more efficient here (though the +-- implementation would be significantly messier). +intersectionWith :: (a -> b -> c) -> IMap a -> IMap b -> IMap c +intersectionWith f (IMap runsa) (IMap runsb) + = IMap . IM.fromDistinctAscList $ merge (IM.toAscList runsa) (IM.toAscList runsb) + where + merge as@((ka, ra):at) bs@((kb, rb):bt) + | ka' < kb = merge at bs + | kb' < ka = merge as bt + | otherwise = (kc, Run (kc' - kc + 1) vc) : case compare ka' kb' of + LT -> merge at bs + EQ -> merge at bt + GT -> merge as bt + where + ka' = ka + len ra - 1 + kb' = kb + len rb - 1 + kc = max ka kb + kc' = min ka' kb' + vc = f (val ra) (val rb) + merge _ _ = [] + +mapMaybe :: (a -> Maybe b) -> IMap a -> IMap b +mapMaybe f (IMap runs) = IMap (IM.mapMaybe (traverse f) runs) + +fromList :: [(Int, Run a)] -> IMap a +fromList = foldl' (\m (k, r) -> insert k r m) empty + +-- | This function is unsafe because 'IMap's that compare equal may split their +-- runs into different chunks; consumers must promise that they do not treat +-- run boundaries specially. +unsafeToAscList :: IMap a -> [(Int, Run a)] +unsafeToAscList = IM.toAscList . _runs + +-- | This function is unsafe because it assumes there is no overlap between its +-- arguments. That is, in the call @unsafeUnion a b@, the caller must guarantee +-- that if @lookup k a = Just v@ then @lookup k b = Nothing@ and vice versa. +unsafeUnion :: IMap a -> IMap a -> IMap a +unsafeUnion a b = IMap { _runs = _runs a `IM.union` _runs b } diff --git a/src/Data/Text/Markup.hs b/src/Data/Text/Markup.hs deleted file mode 100644 --- a/src/Data/Text/Markup.hs +++ /dev/null @@ -1,74 +0,0 @@ --- | This module provides an API for "marking up" text with arbitrary --- values. A piece of markup can then be converted to a list of pairs --- representing the sequences of characters assigned the same markup --- value. --- --- This interface is experimental. Don't use this for your full-file --- syntax highlighter just yet! -module Data.Text.Markup - ( Markup - , markupToList - , markupSet - , fromList - , fromText - , toText - , (@@) - ) -where - -import Control.Applicative ((<$>)) -import Data.Default (Default, def) -import Data.Monoid -import Data.String (IsString(..)) -import qualified Data.Text as T - --- | Markup with metadata type 'a' assigned to each character. -data Markup a = Markup [(Char, a)] - deriving Show - -instance Monoid (Markup a) where - mempty = Markup mempty - mappend (Markup t1) (Markup t2) = - Markup (t1 `mappend` t2) - -instance (Default a) => IsString (Markup a) where - fromString = fromText . T.pack - --- | Build a piece of markup; assign the specified metadata to every --- character in the specified text. -(@@) :: T.Text -> a -> Markup a -t @@ val = Markup [(c, val) | c <- T.unpack t] - --- | Build markup from text with the default metadata. -fromText :: (Default a) => T.Text -> Markup a -fromText = (@@ def) - --- | Extract the text from markup, discarding the markup metadata. -toText :: (Eq a) => Markup a -> T.Text -toText = T.concat . (fst <$>) . markupToList - --- | Set the metadata for a range of character positions in a piece of --- markup. This is useful for, e.g., syntax highlighting. -markupSet :: (Eq a) => (Int, Int) -> a -> Markup a -> Markup a -markupSet (start, len) val m@(Markup l) = if start < 0 || start + len > length l - then m - else newM - where - newM = Markup $ theHead ++ theNewEntries ++ theTail - (theHead, theLongTail) = splitAt start l - (theOldEntries, theTail) = splitAt len theLongTail - theNewEntries = zip (fst <$> theOldEntries) (repeat val) - --- | Convert markup to a list of pairs in which each pair contains the --- longest subsequence of characters having the same metadata. -markupToList :: (Eq a) => Markup a -> [(T.Text, a)] -markupToList (Markup thePairs) = toList thePairs - where - toList [] = [] - toList ((ch, val):rest) = (T.pack $ ch : (fst <$> matching), val) : toList remaining - where - (matching, remaining) = break (\(_, v) -> v /= val) rest - --- | Convert a list of text and metadata pairs into markup. -fromList :: [(T.Text, a)] -> Markup a -fromList pairs = Markup $ concatMap (\(t, val) -> [(c, val) | c <- T.unpack t]) pairs diff --git a/tests/List.hs b/tests/List.hs new file mode 100644 --- /dev/null +++ b/tests/List.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module List + ( main + ) +where + +import Prelude hiding (reverse, splitAt) + +import Data.Foldable (find) +import Data.Function (on) +import qualified Data.List +import Data.Maybe (isNothing) +import Data.Monoid (Endo(..)) +import Data.Proxy +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup((<>))) +#endif + +import qualified Data.Sequence as Seq +import qualified Data.Vector as V +import Lens.Micro +import Test.QuickCheck + +import Brick.Util (clamp) +import Brick.Widgets.List + +instance (Arbitrary n, Arbitrary a) => Arbitrary (List n a) where + arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1 + +-- List move operations that never modify the underlying list +data ListMoveOp a = + MoveUp + | MoveDown + | MoveBy Int + | MoveTo Int + | MoveToElement a + | FindElement a + deriving (Show) + +instance Arbitrary a => Arbitrary (ListMoveOp a) where + arbitrary = + oneof [ pure MoveUp + , pure MoveDown + , MoveBy <$> arbitrary + , MoveTo <$> arbitrary + , MoveToElement <$> arbitrary + , FindElement <$> arbitrary + ] + +-- List operations. We don't have "page"-based movement operations +-- because these depend on render context (i.e. effect in EventM) +data ListOp a = + Insert Int a + | Remove Int + | Replace Int [a] + | Clear + | Reverse + | ListMoveOp (ListMoveOp a) + deriving (Show) + +instance Arbitrary a => Arbitrary (ListOp a) where + arbitrary = + frequency [ (1, Insert <$> arbitrary <*> arbitrary) + , (1, Remove <$> arbitrary) + , (1, Replace <$> arbitrary <*> arbitrary) + , (1, pure Clear) + , (1, pure Reverse) + , (6, arbitrary) + ] + +-- Turn a ListOp into a List endomorphism +op :: Eq a => ListOp a -> List n a -> List n a +op (Insert i a) = listInsert i a +op (Remove i) = listRemove i +op (Replace i xs) = + -- avoid setting index to Nothing + listReplace (V.fromList xs) (Just i) +op Clear = listClear +op Reverse = listReverse +op (ListMoveOp mo) = moveOp mo + +-- Turn a ListMoveOp into a List endomorphism +moveOp :: (Eq a) => ListMoveOp a -> List n a -> List n a +moveOp MoveUp = listMoveUp +moveOp MoveDown = listMoveDown +moveOp (MoveBy n) = listMoveBy n +moveOp (MoveTo n) = listMoveTo n +moveOp (MoveToElement a) = listMoveToElement a +moveOp (FindElement a) = listFindBy (== a) + +applyListOps :: (Foldable t) + => (op a -> List n a -> List n a) + -> t (op a) + -> List n a + -> List n a +applyListOps f = appEndo . foldMap (Endo . f) + +-- | Initial selection is always 0 (or Nothing for empty list) +prop_initialSelection :: [a] -> Bool +prop_initialSelection xs = + list () (V.fromList xs) 1 ^. listSelectedL == + if null xs then Nothing else Just 0 + +-- list operations keep the selected index in bounds +prop_listOpsMaintainSelectedValid :: (Eq a) + => [ListOp a] + -> List n a + -> Bool +prop_listOpsMaintainSelectedValid ops l = + let l' = applyListOps op ops l + in case l' ^. listSelectedL of + -- either there is no selection and list is empty + Nothing -> null l' + -- or the selected index is valid + Just i -> i >= 0 && i < length l' + +-- reversing a list keeps the selected element the same +prop_reverseMaintainsSelectedElement :: (Eq a) + => [ListOp a] + -> List n a + -> Bool +prop_reverseMaintainsSelectedElement ops l = + -- apply some random list ops to (probably) set a selected element + let l' = applyListOps op ops l + l'' = listReverse l' + in fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'') + +-- reversing maintains size of list +prop_reverseMaintainsSizeOfList :: List n a -> Bool +prop_reverseMaintainsSizeOfList l = + length l == length (listReverse l) + +-- an inserted element may always be found at the given index +-- (when target index is clamped to 0 <= n <= len) +prop_insert :: (Eq a) => Int -> a -> List n a -> Bool +prop_insert i a l = + let l' = listInsert i a l + i' = clamp 0 (length l) i + in listSelectedElement (listMoveTo i' l') == Just (i', a) + +-- inserting anywhere always increases size of list by 1 +prop_insertSize :: (Eq a) => Int -> a -> List n a -> Bool +prop_insertSize i a l = + let l' = listInsert i a l + in length l' == length l + 1 + +-- inserting an element and moving to it always succeeds and +-- the selected element is the one we inserted. +-- +-- The index is not necessarily the index we inserted at, because +-- the element could be present in the original list. So we don't +-- check that. +-- +prop_insertMoveTo :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool +prop_insertMoveTo ops l i a = + let l' = listInsert i a (applyListOps op ops l) + sel = listSelectedElement (listMoveToElement a l') + in fmap snd sel == Just a + +-- inserting an element and repeatedly seeking it always +-- reaches the element we inserted, at the index where we +-- inserted it. +-- +prop_insertFindBy :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool +prop_insertFindBy ops l i a = + let l' = applyListOps op ops l + l'' = set listSelectedL Nothing . listInsert i a $ l' + seeks = converging ((==) `on` (^. listSelectedL)) (listFindBy (== a)) l'' + i' = clamp 0 (length l') i -- we can't have inserted past len + in (find ((== Just i') . (^. listSelectedL)) seeks >>= listSelectedElement) == Just (i', a) + +-- inserting then deleting always yields a list with the original elems +prop_insertRemove :: (Eq a) => Int -> a -> List n a -> Bool +prop_insertRemove i a l = + let i' = clamp 0 (length l) i + l' = listInsert i' a l -- pre-clamped + l'' = listRemove i' l' + in l'' ^. listElementsL == l ^. listElementsL + +-- deleting in-bounds always reduces size of list by 1 +-- deleting out-of-bounds never changes list size +prop_remove :: Int -> List n a -> Bool +prop_remove i l = + let len = length l + i' = clamp 0 (len - 1) i + test + | len > 0 && i == i' = (== len - 1) -- i is in bounds + | otherwise = (== len) -- i is out of bounds + in test (length (listRemove i l)) + +-- deleting an element and re-inserting it at same position +-- gives the original list elements +prop_removeInsert :: (Eq a) => Int -> List n a -> Bool +prop_removeInsert i l = + let sel = listSelectedElement (listMoveTo i l) + l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l + in l' ^. listElementsL == l ^. listElementsL + +-- Apply @f@ until @test a (f a) == True@, then return @a@. +converge :: (a -> a -> Bool) -> (a -> a) -> a -> a +converge test f = last . converging test f + +-- Apply @f@ until @test a (f a) == True@, returning the start, +-- intermediate and final values as a list. +converging :: (a -> a -> Bool) -> (a -> a) -> a -> [a] +converging test f a + | test a (f a) = [a] + | otherwise = a : converging test f (f a) + +-- listMoveUp always reaches 0 (or list is empty) +prop_moveUp :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_moveUp ops l = + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l' + len = length l'' + in maybe (len == 0) (== 0) (l'' ^. listSelectedL) + +-- listMoveDown always reaches end of list (or list is empty) +prop_moveDown :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_moveDown ops l = + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l' + len = length l'' + in maybe (len == 0) (== len - 1) (l'' ^. listSelectedL) + +-- move ops never change the list +prop_moveOpsNeverChangeList :: (Eq a) => [ListMoveOp a] -> List n a -> Bool +prop_moveOpsNeverChangeList ops l = + let l' = applyListOps moveOp ops l + in l' ^. listElementsL == l ^. listElementsL + +-- If the list is empty, empty selection is used. +-- Otherwise, if the specified selected index is not in list bounds, +-- zero is used instead. +prop_replaceSetIndex :: (Eq a) + => [ListOp a] + -> List n a + -> [a] + -> Int + -> Bool +prop_replaceSetIndex ops l xs i = + let v = V.fromList xs + l' = applyListOps op ops l + l'' = listReplace v (Just i) l' + i' = clamp 0 (length v - 1) i + inBounds = i == i' + in l'' ^. listSelectedL == case (null v, inBounds) of + (True, _) -> Nothing + (False, True) -> Just i + (False, False) -> Just 0 + +-- Replacing with no index always clears the index +prop_replaceNoIndex :: (Eq a) => [ListOp a] -> List n a -> [a] -> Bool +prop_replaceNoIndex ops l xs = + let v = V.fromList xs + l' = applyListOps op ops l + in isNothing (listReplace v Nothing l' ^. listSelectedL) + +-- | Move the list selected index. If the index is `Just x`, adjust by the +-- specified amount; if it is `Nothing` (i.e. there is no selection) and the +-- direction is positive, set to `Just 0` (first element), otherwise set to +-- `Just (length - 1)` (last element). Subject to validation. +prop_moveByWhenNoSelection :: List n a -> Int -> Property +prop_moveByWhenNoSelection l amt = + let l' = l & listSelectedL .~ Nothing + len = length l + expected = if amt > 0 then 0 else len - 1 + in len > 0 ==> listMoveBy amt l' ^. listSelectedL == Just expected + +splitAtLength :: (Foldable t, Splittable t) => t a -> Int -> Bool +splitAtLength l i = + let len = length l + (h, t) = splitAt i l + in length h + length t == len && length h == clamp 0 len i + +splitAtAppend :: (Splittable t, Semigroup (t a), Eq (t a)) + => t a -> Int -> Bool +splitAtAppend l i = uncurry (<>) (splitAt i l) == l + +prop_splitAtLength_Vector :: [a] -> Int -> Bool +prop_splitAtLength_Vector = splitAtLength . V.fromList + +prop_splitAtAppend_Vector :: (Eq a) => [a] -> Int -> Bool +prop_splitAtAppend_Vector = splitAtAppend . V.fromList + +prop_splitAtLength_Seq :: [a] -> Int -> Bool +prop_splitAtLength_Seq = splitAtLength . Seq.fromList + +prop_splitAtAppend_Seq :: (Eq a) => [a] -> Int -> Bool +prop_splitAtAppend_Seq = splitAtAppend . Seq.fromList + + +reverseSingleton :: forall t a. (Reversible t, Applicative t, Eq (t a)) + => Proxy t -> a -> Bool +reverseSingleton _ a = + let l = pure a :: t a + in reverse l == l + +reverseAppend :: (Reversible t, Semigroup (t a), Eq (t a)) + => t a -> t a -> Bool +reverseAppend l1 l2 = + reverse (l1 <> l2) == reverse l2 <> reverse l1 + +prop_reverseSingleton_Vector :: (Eq a) => a -> Bool +prop_reverseSingleton_Vector = reverseSingleton (Proxy :: Proxy V.Vector) + +prop_reverseAppend_Vector :: (Eq a) => [a] -> [a] -> Bool +prop_reverseAppend_Vector l1 l2 = + reverseAppend (V.fromList l1) (V.fromList l2) + +prop_reverseSingleton_Seq :: (Eq a) => a -> Bool +prop_reverseSingleton_Seq = reverseSingleton (Proxy :: Proxy Seq.Seq) + +prop_reverseAppend_Seq :: (Eq a) => [a] -> [a] -> Bool +prop_reverseAppend_Seq l1 l2 = + reverseAppend (Seq.fromList l1) (Seq.fromList l2) + +-- Laziness tests. Here we create a custom container type +-- that we use to ensure certain operations do not cause the +-- whole container to be evaluated. +-- +newtype L a = L [a] + deriving (Functor, Foldable, Traversable, Semigroup) + +instance Splittable L where + splitAt i (L xs) = over both L (Data.List.splitAt i xs) + +-- moveBy positive amount does not evaluate 'length' +prop_moveByPosLazy :: Bool +prop_moveByPosLazy = + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 + l' = listMoveBy 1 l + in l' ^. listSelectedL == Just 1 + +-- listFindBy is lazy +prop_findByLazy :: Bool +prop_findByLazy = + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Nothing + l' = listFindBy even l + l'' = listFindBy even l' + in l' ^. listSelectedL == Just 1 && + l'' ^. listSelectedL == Just 3 + +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 = + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Just 3 + in listSelectedElement l == Just (3, 4) + +prop_listSelectedElementL_lazy :: Bool +prop_listSelectedElementL_lazy = + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Just 3 + in over listSelectedElementL (*2) l ^? listSelectedElementL == Just 8 + +return [] + +main :: IO Bool +main = $quickCheckAll diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,117 @@ +{-# 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)) +import Data.IntMap (IntMap) +import Test.QuickCheck +import qualified Data.IMap as IMap +import qualified Data.IntMap as IntMap + +import qualified List +import qualified Render + +instance Arbitrary v => Arbitrary (Run v) where + arbitrary = liftA2 (\(Positive n) -> Run n) arbitrary arbitrary + +instance Arbitrary v => Arbitrary (IMap v) where + arbitrary = IMap.fromList <$> arbitrary + +instance (a ~ Ordering, Show b) => Show (a -> b) where + show f = show [f x | x <- [minBound .. maxBound]] + +lower :: IMap v -> IntMap v +lower m = IntMap.fromDistinctAscList + [ (base+offset, v) + | (base, Run n v) <- IMap.unsafeToAscList m + , offset <- [0..n-1] + ] + +raise :: Eq v => IntMap v -> IMap v +raise = IMap.fromList . rle . map singletonRun . IntMap.toAscList where + singletonRun (k, v) = (k, Run 1 v) + + rle ((k, Run n v):(k', Run n' v'):kvs) + | k+n == k' && v == v' = rle ((k, Run (n+n') v):kvs) + rle (kv:kvs) = kv:rle kvs + rle [] = [] + +lowerRun :: Int -> Run v -> IntMap v +lowerRun k r = IntMap.fromAscList [(k+offset, IMap.val r) | offset <- [0..IMap.len r-1]] + +type O = Ordering +type I = IMap Ordering + +-- These next two probably have overflow bugs that QuickCheck can't reasonably +-- notice. Hopefully they don't come up in real use cases... +prop_raiseLowerFaithful :: IntMap O -> Bool +prop_raiseLowerFaithful m = m == lower (raise m) + +prop_equalityReflexive :: I -> Bool +prop_equalityReflexive m = m == raise (lower m) + +prop_equality :: I -> I -> Bool +prop_equality l r = (l == r) == (lower l == lower r) + +prop_compare :: I -> I -> Bool +prop_compare l r = compare l r == compare (lower l) (lower r) + +prop_applicativeIdentity :: I -> Bool +prop_applicativeIdentity v = (id <$> v) == v + +prop_applicativeComposition :: IMap (O -> O) -> IMap (O -> O) -> IMap O -> Bool +prop_applicativeComposition u v w = ((.) <$> u <*> v <*> w) == (u <*> (v <*> w)) + +prop_applicativeHomomorphism :: (O -> O) -> O -> Bool +prop_applicativeHomomorphism f x = (f <$> pure x :: I) == pure (f x) + +prop_applicativeInterchange :: IMap (O -> O) -> O -> Bool +prop_applicativeInterchange u y = (u <*> pure y) == (($ y) <$> u) + +prop_empty :: Bool +prop_empty = lower (IMap.empty :: I) == IntMap.empty + +prop_singleton :: Int -> Run O -> Bool +prop_singleton k r = lower (IMap.singleton k r) == lowerRun k r + +prop_insert :: Int -> Run O -> I -> Bool +prop_insert k r m = lower (IMap.insert k r m) == IntMap.union (lowerRun k r) (lower m) + +prop_delete :: Int -> Run () -> I -> Bool +prop_delete k r m = lower (IMap.delete k r m) == lower m IntMap.\\ lowerRun k r + +prop_splitLE :: Int -> I -> Bool +prop_splitLE k m = (lower le, lower gt) == (le', gt') where + (le, gt) = IMap.splitLE k m + (lt, eq, gt') = IntMap.splitLookup k (lower m) + le' = maybe id (IntMap.insert k) eq lt + +prop_intersectionWith :: (O -> O -> O) -> I -> I -> Bool +prop_intersectionWith f l r = lower (IMap.intersectionWith f l r) == IntMap.intersectionWith f (lower l) (lower r) + +prop_addToKeys :: Int -> I -> Bool +prop_addToKeys n m = lower (IMap.addToKeys n m) == IntMap.mapKeysMonotonic (n+) (lower m) + +prop_lookup :: Int -> I -> Bool +prop_lookup k m = IMap.lookup k m == IntMap.lookup k (lower m) + +prop_restrict :: Int -> Run () -> I -> Bool +prop_restrict k r m = lower (IMap.restrict k r m) == IntMap.intersection (lower m) (lowerRun k r) + +prop_mapMaybe :: (O -> Maybe O) -> I -> Bool +prop_mapMaybe f m = lower (IMap.mapMaybe f m) == IntMap.mapMaybe f (lower m) + +prop_null :: I -> Bool +prop_null m = IMap.null m == IntMap.null (lower m) + +return [] + +main :: IO () +main = + (and <$> sequenceA [$quickCheckAll, List.main, Render.main]) + >>= bool exitFailure exitSuccess diff --git a/tests/Render.hs b/tests/Render.hs new file mode 100644 --- /dev/null +++ b/tests/Render.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +module Render + ( main + ) +where + +import Brick +import Control.Monad (when) +#if !(MIN_VERSION_base(4,11,0)) +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) + +region :: V.DisplayRegion +region = (30, 10) + +renderDisplay :: Ord n => [Widget n] -> IO () +renderDisplay ws = do + outp <- V.mkDefaultOutput + ctx <- V.displayContext outp region + V.outputPicture ctx (renderWidget Nothing ws region) + V.releaseDisplay outp + +myWidget :: Widget () +myWidget = str "Why" <=> hBorder <=> str "not?" + +-- Since you can't Read a Picture, we have to compare the result with +-- the Shown one +expectedResult :: String +expectedResult = "Picture {picCursor = NoCursor, picLayers = [VertJoin {partTop = VertJoin {partTop = HorizText {attr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}, displayText = \"Why \", outputWidth = 30, charWidth = 30}, partBottom = VertJoin {partTop = HorizText {attr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}, displayText = \"\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\", outputWidth = 30, charWidth = 30}, partBottom = HorizText {attr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}, displayText = \"not? \", outputWidth = 30, charWidth = 30}, outputWidth = 30, outputHeight = 2}, outputWidth = 30, outputHeight = 3}, partBottom = BGFill {outputWidth = 30, outputHeight = 7}, outputWidth = 30, outputHeight = 10}], picBackground = Background {backgroundChar = ' ', backgroundAttr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}}}" + +main :: IO Bool +main = do + result <- try (renderDisplay [myWidget]) :: IO (Either SomeException ()) + case result of + Left _ -> do + putStrLn "Terminal is not available, skipping test" + -- Even though we could not actually run the test, we return + -- True here to prevent the absence of a terminal from + -- causing a test suite failure in an automated context. + -- This means that this test effectively doesn't get + -- considered at all in the automated context. + return True + Right () -> do + let matched = actualResult == expectedResult + actualResult = show (renderWidget Nothing [myWidget] region) + msg = if matched then "rendering match" else "rendering mismatch" + + putStrLn "" + putStrLn $ "renderWidget test outcome: " <> msg + + when (not matched) $ do + putStrLn "Expected result:" + putStrLn expectedResult + + putStrLn "Actual result:" + putStrLn actualResult + + return matched