diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,922 @@ Brick changelog --------------- +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 ------ @@ -239,14 +1155,14 @@ * 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 - concatentation settings default to their former hard-coded values, + concatenation settings default to their former hard-coded values, `vBox` (#172). 0.36.1 ------ Package changes: - * Raiseed upper bound to support GHC 8.4.2 (#171) + * Raised upper bound to support GHC 8.4.2 (#171) Other changes: * Improved List accessor documentation (thanks liam ) @@ -260,7 +1176,7 @@ * 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 demonstraton. Also see the + `programs/DynamicBorderDemo.hs` for a demonstration. Also see the "Joinable Borders" section of the User Guide. 0.35.1 @@ -956,7 +1872,7 @@ Bug fixes: * Fixed viewport behavior when the image in a viewport reduces its size enough to render the viewport offsets invalid. Before, this behavior - caused a crash during image croppin in vty; now the behavior is + caused a crash during image cropping in vty; now the behavior is handled sanely (fixes #22; reported by Hans-Peter Deifel) 0.2.2 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2018, Jonathan Daugherty. +Copyright (c) 2015-2025, Jonathan Daugherty. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,17 +2,20 @@ `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 look based on your current application state and you -provide a state transformation function to handle events. +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 using a set of declarative layout combinators. +require you to write a long and tedious sequence of widget creations +and layout setup, `brick` just requires you to describe your interface +using a set of declarative layout combinators. Event-handling is done by +pattern-matching on incoming events and updating your application state. Under the hood, this library builds upon [vty](http://hackage.haskell.org/package/vty), so some knowledge of Vty -will be helpful in using this library. +will be necessary to use this library. Brick depends on +`vty-crossplatform`, so Brick should work anywhere Vty works (Unix and +Windows). Brick releases prior to 2.0 only support Unix-based systems. Example ------- @@ -20,6 +23,7 @@ Here's an example interface (see `programs/ReadmeDemo.hs`): ``` +joinBorders $ withBorderStyle unicode $ borderWithLabel (str "Hello!") $ (center (str "Left") <+> vBorder <+> center (str "Right")) @@ -34,44 +38,81 @@ │ Left │ Right │ │ │ │ │ │ │ -└────────────────────────┘ +└───────────┴────────────┘ ``` Featured Projects ----------------- -To get an idea of what some people have done with `brick`, take a look -at these projects: - - * `tetris`, an implementation of the Tetris game: https://github.com/SamTay/tetris - * `gotta-go-fast`, a typing tutor: https://github.com/callum-oakley/gotta-go-fast - * `haskell-player`, an `afplay` frontend: https://github.com/potomak/haskell-player - * `mushu`, an `MPD` client: https://github.com/elaye/mushu - * `matterhorn`, a client for [Mattermost](https://about.mattermost.com/): https://github.com/matterhorn-chat/matterhorn - * `viewprof`, a GHC profile viewer: https://github.com/maoe/viewprof - * `tart`, a mouse-driven ASCII art drawing program: https://github.com/jtdaugherty/tart - * `silly-joy`, an interpreter for Joy: https://github.com/rootmos/silly-joy - * `herms`, a command-line tool for managing kitchen recipes: https://github.com/jackkiefer/herms - * `purebred`, a mail user agent: https://github.com/purebred-mua/purebred - * `2048Haskell`, an implementation of the 2048 game: https://github.com/8Gitbrix/2048Haskell - * `bhoogle`, a [Hoogle](https://www.haskell.org/hoogle/) client: https://github.com/andrevdm/bhoogle - * `clifm`, a file manager: https://github.com/pasqu4le/clifm - * `towerHanoi`, animated solutions to The Tower of Hanoi: https://github.com/shajenM/projects/tree/master/towerHanoi - * `VOIDSPACE`, a space-themed typing-tutor game: https://github.com/ChrisPenner/void-space - * `solitaire`, the card game: https://github.com/ambuc/solitaire - * `sudoku-tui`, a Sudoku implementation: https://github.com/evanrelf/sudoku-tui - * `summoner-tui`, an interactive frontend to the Summoner tool: https://github.com/kowainik/summoner/tree/master/summoner-tui - -These third-party packages also extend `brick`: - - * [`brick-filetree`](https://github.com/ChrisPenner/brick-filetree) [[Hackage]](http://hackage.haskell.org/package/brick-filetree) - A widget for exploring a directory tree and selecting or flagging files and directories +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! -Release Announcements / News ----------------------------- +| 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 | -Find out about `brick` releases and other news on Twitter: +These additional packages also extend `brick`: -https://twitter.com/brick_haskell/ +| Project | Description | Hackage | +| ------- | ----------- | ------- | +| [`brick-filetree`](https://github.com/ChrisPenner/brick-filetree) | A widget for exploring a directory tree and selecting or flagging files and directories | [Hackage](https://hackage.haskell.org/package/brick-filetree) | +| [`brick-panes`](https://github.com/kquick/brick-panes) | A Brick overlay library providing composition and isolation of screen areas for TUI apps. | [Hackage](https://hackage.haskell.org/package/brick-panes) | +| [`brick-calendar`](https://github.com/ldgrp/brick-calendar) | A library providing a calendar widget for Brick-based applications. | [Hackage](https://hackage.haskell.org/package/brick-calendar) | +| [`brick-skylighting`](https://github.com/jtdaugherty/brick-skylighting) | A library providing integration support for [Skylighting](https://hackage.haskell.org/package/skylighting)-based syntax highlighting. | [Hackage](https://hackage.haskell.org/package/brick-skylighting) | Getting Started --------------- @@ -92,8 +133,7 @@ Documentation for `brick` comes in a variety of forms: * [The official brick user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst) -* [Samuel Tay's brick tutorial](https://github.com/jtdaugherty/brick/blob/master/docs/samtay-tutorial.md) -* Haddock (all modules) +* [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) @@ -104,26 +144,28 @@ * Vertical and horizontal box layout widgets * Basic single- and multi-line text editor widgets - * List widget + * List and table widgets * Progress bar widget * Simple dialog box widget * Border-drawing widgets (put borders around or in between things) - * Generic scrollable viewports + * 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-Users Discussion ----------------------- -The `brick-users` Google Group / e-mail list is a place to discuss -library changes, give feedback, and ask questions. You can subscribe at: +Brick Discussion +---------------- -[https://groups.google.com/group/brick-users](https://groups.google.com/group/brick-users) +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 ------ @@ -142,14 +184,24 @@ packages and widgets. If you use that, you'll also be helping to test whether the exported interface is usable and complete! +A note on Windows support +------------------------- + +Brick supports Windows implicitly by way of Vty's Windows support. +While I don't (and can't) personally test Brick on Windows hosts, +it should be possible to use Brick on Windows. If you have any +trouble, report any issues here. If needed, we'll migrate them to the +[vty-windows](https://github.com/chhackett/vty-windows) repository if +they need to be fixed there. + Reporting bugs -------------- Please file bug reports as GitHub issues. For best results: - Include the versions of relevant software packages: your terminal - emulator, `brick`, `ghc`, and `vty` will be the most important - ones. + emulator, `brick`, `ghc`, `vty`, and Vty platform packages will be + the most important ones. - Clearly describe the behavior you expected ... @@ -162,6 +214,8 @@ If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: + - Patches written completely or partially by AI are unlikely to be + accepted. - 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. @@ -169,7 +223,12 @@ codebase. - Please adjust or provide Haddock and/or user guide documentation relevant to any changes you make. - - New commits should be `-Wall` clean. + - Please ensure that commits are `-Wall` clean. + - Please ensure that each commit makes a single, logical, isolated + change as much as possible. + - Please do not submit changes that your linter told you to make. I + will probably decline them. Relatedly: please do not submit changes + that change only style without changing functionality. - Please do NOT include package version changes in your patches. Package version changes are only done at release time when the full scope of a release's changes can be evaluated to determine the diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,9 +1,10 @@ name: brick -version: 0.47.1 +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 @@ -31,23 +32,34 @@ license-file: LICENSE author: Jonathan Daugherty maintainer: Jonathan Daugherty -copyright: (c) Jonathan Daugherty 2015-2018 +copyright: (c) Jonathan Daugherty 2015-2025 category: Graphics build-type: Simple cabal-version: 1.18 Homepage: https://github.com/jtdaugherty/brick/ Bug-reports: https://github.com/jtdaugherty/brick/issues -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.6.5 +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 extra-doc-files: README.md, docs/guide.rst, - docs/samtay-tutorial.md, docs/snake-demo.gif, - CHANGELOG.md + 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 @@ -55,18 +67,25 @@ 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 @@ -79,68 +98,117 @@ Brick.Widgets.FileBrowser Brick.Widgets.List Brick.Widgets.ProgressBar + Brick.Widgets.Table Data.IMap - Data.Text.Markup other-modules: + Brick.Animation.Clock Brick.Types.Common Brick.Types.TH + Brick.Types.EventM Brick.Types.Internal Brick.Widgets.Internal - build-depends: base <= 4.12.0.0, - vty >= 5.24, - transformers, + 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, - dlist, + exceptions >= 0.10.0, filepath, containers >= 0.5.7, - microlens >= 0.3.0.0, + microlens >= 0.3.0.0 && < 0.6, microlens-th, microlens-mtl, + mtl, config-ini, vector, - contravariant, - stm >= 2.4, + stm >= 2.4.3, text, - text-zipper >= 0.7.1, + text-zipper >= 0.13, template-haskell, - deepseq >= 1.3 && < 1.5, - unix, - word-wrap >= 0.2 - if impl(ghc < 8.0) - build-depends: semigroups + 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 -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 default-extensions: CPP main-is: ReadmeDemo.hs build-depends: base, - brick, - text + brick executable brick-file-browser-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: FileBrowserDemo.hs build-depends: base, vty, brick, - text + text, + mtl executable brick-form-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: FormDemo.hs @@ -149,311 +217,344 @@ 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 -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 default-extensions: CPP main-is: TextWrapDemo.hs build-depends: base, brick, - text, word-wrap executable brick-cache-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: CacheDemo.hs build-depends: base, brick, vty, - text, - microlens >= 0.3.0.0, - microlens-th + 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, - text, 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, - text, - microlens + 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, brick, - vty, - text, - microlens + vty executable brick-mouse-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: MouseDemo.hs build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-th, - text-zipper + 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, brick, vty, - text, microlens >= 0.3.0.0, - microlens-th + 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, brick, vty, - text, 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, brick, - vty, - text, - microlens + vty executable brick-theme-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: ThemeDemo.hs build-depends: base, brick, vty, - text, - microlens + 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, brick, - vty, - text, - microlens + 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 + main-is: TabularListDemo.hs build-depends: base, brick, vty, - text, - microlens + microlens >= 0.3.0.0, + microlens-mtl, + microlens-th, + vector executable brick-list-demo if !flag(demos) 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, brick, vty, - text, 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 -fno-warn-unused-do-bind -O3 + ghc-options: -threaded -Wall -Wcompat -O2 default-language: Haskell2010 main-is: ListViDemo.hs build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, + microlens-mtl, + mtl, vector +executable brick-animation-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: AnimationDemo.hs + build-depends: base, + brick, + vty, + vty-crossplatform, + containers, + microlens-platform + executable brick-custom-event-demo if !flag(demos) Buildable: False 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, brick, vty, - text, microlens >= 0.3.0.0, - microlens-th + microlens-th, + microlens-mtl executable brick-fill-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: FillDemo.hs build-depends: base, - brick, - vty, - text, - microlens + 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, - brick, - vty, - text, - microlens + 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, brick, vty, - text, - vector, microlens >= 0.3.0.0, - microlens-th + 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, - microlens + text executable brick-dynamic-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: DynamicBorderDemo.hs build-depends: base <= 5, - brick, - vty, - text, - microlens + brick executable brick-progressbar-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: ProgressBarDemo.hs build-depends: base, brick, vty, - text, - microlens + microlens-mtl, + microlens-th test-suite brick-tests type: exitcode-stdio-1.0 hs-source-dirs: tests - ghc-options: -Wall -O2 - if impl(ghc >= 8) - ghc-options: -Wno-orphans + ghc-options: -Wall -Wcompat -Wno-orphans -O2 default-language: Haskell2010 main-is: Main.hs - other-modules: List + other-modules: List Render build-depends: base <=5, brick, containers, microlens, vector, + vty, + vty-crossplatform, QuickCheck - if impl(ghc < 8.0) - build-depends: semigroups diff --git a/docs/guide.rst b/docs/guide.rst --- a/docs/guide.rst +++ b/docs/guide.rst @@ -11,7 +11,8 @@ 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. +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 @@ -21,7 +22,7 @@ two important functions: - A *drawing function* that turns your application state into a - specification of how your interface should look, and + 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. @@ -30,9 +31,9 @@ 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`_. +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 ------------ @@ -52,6 +53,13 @@ $ cd brick $ cabal new-build +Your package will need some dependencies: + +* ``brick``, +* ``vty >= 6.0``, and +* ``vty-crossplatform`` or ``vty-unix`` or ``vty-windows``, depending + on which platform(s) your application supports. + Building the Demonstration Programs ----------------------------------- @@ -68,16 +76,17 @@ documentation and as you explore the library source and write your own programs. -- Use of `microlens`_ packages: ``brick`` uses ``microlens`` family of - packages internally and also exposes lenses for many types in the +- Use of `microlens`_ packages: ``brick`` uses the ``microlens`` family + of packages internally and also exposes lenses for many types in the library. However, if you prefer not to use the lens interface in your program, all lens interfaces have non-lens equivalents exported by the same module. In general, the "``L``" suffix on something tells you it is a lens; the name without the "``L``" suffix is the non-lens - version. You can get by without using ``brick``'s lens interface but - your life will probably be much more pleasant once your application - state becomes sufficiently complex if you use lenses to modify it (see - `appHandleEvent: Handling Events`_). + version. You can get by without using ``brick``'s lens interface + but your life will probably be much more pleasant if you use lenses + to modify your application state once it becomes sufficiently + complex (see `appHandleEvent: Handling Events`_ and `Event Handlers + for Component State`_). - Attribute names: some modules export attribute names (see `How Attributes Work`_) associated with user interface elements. These tend to end in an "``Attr``" suffix (e.g. ``borderAttr``). In addition, @@ -96,8 +105,8 @@ Brick applications must be compiled with the threaded RTS using the GHC ``-threaded`` option. -The App Type -============ +The ``App`` Type +================ To use the library we must provide it with a value of type ``Brick.Main.App``. This type is a record type whose fields perform @@ -108,8 +117,8 @@ data App s e n = App { appDraw :: s -> [Widget n] , appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n) - , appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) - , appStartEvent :: s -> EventM n s + , appHandleEvent :: BrickEvent n e -> EventM n s () + , appStartEvent :: EventM n s () , appAttrMap :: s -> AttrMap } @@ -150,16 +159,16 @@ main :: IO () main = do - let app = App { ... } - initialState = ... - finalState <- defaultMain app initialState - -- Use finalState and exit + let app = App { ... } + initialState = ... + finalState <- defaultMain app initialState + -- Use finalState and exit The ``customMain`` function is for more advanced uses; for details see `Using Your Own Event Type`_. -appDraw: Drawing an Interface ------------------------------ +``appDraw``: Drawing an Interface +--------------------------------- The value of ``appDraw`` is a function that turns the current application state into a list of *layers* of type ``Widget``, listed @@ -201,109 +210,162 @@ ``Brick.Widgets.Core``. Beyond that, any module in the ``Brick.Widgets`` namespace provides specific kinds of functionality. -appHandleEvent: Handling Events -------------------------------- +``appHandleEvent``: Handling Events +----------------------------------- The value of ``appHandleEvent`` is a function that decides how to modify the application state as a result of an event: .. code:: haskell - appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) + appHandleEvent :: BrickEvent n e -> EventM n s () -The first parameter of type ``s`` is your application's state at the -time the event arrives. ``appHandleEvent`` is responsible for deciding -how to change the state based on the event and then return it. +``appHandleEvent`` is responsible for deciding how to change the state +based on 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 second parameter of type ``BrickEvent n e`` is the event itself. -The type variables ``n`` and ``e`` correspond to the *resource name -type* and *event type* of your application, respectively, and must match -the corresponding types in ``App`` and ``EventM``. +The ``EventM`` monad is parameterized on the *resource name type* +``n`` and your application's state type ``s``. The ``EventM`` monad +is a state monad over ``s``, so one way to access and modify your +application's state in an event handler is to use the ``MonadState`` +type class and associated operations from the ``mtl`` package. The +recommended approach, however, is to use the lens operations from the +``microlens-mtl`` package with lenses to perform concise state updates. +We'll cover this topic in more detail in `Event Handlers for Component +State`_. -The return value type ``Next s`` value describes what should happen -after the event handler is finished. We have three choices: +Once the event handler has performed any relevant state updates, it can +also indicate what should happen once the event handler has finished +executing. By default, after an event handler has completed, Brick will +redraw the screen with the application state (by calling ``appDraw``) +and wait for the next input event. However, there are two other options: -* ``Brick.Main.continue s``: continue executing the event loop with the - specified application state ``s`` as the next value. Commonly this is - where you'd modify the state based on the event and return it. -* ``Brick.Main.halt s``: halt the event loop and return the final - application state value ``s``. This state value is returned to the - caller of ``defaultMain`` or ``customMain`` where it can be used prior - to finally exiting ``main``. -* ``Brick.Main.suspendAndResume act``: suspend the ``brick`` event loop - and execute the specified ``IO`` action ``act``. The action ``act`` - must be of type ``IO s``, so when it executes it must return the next - application state. When ``suspendAndResume`` is used, the ``brick`` - event loop is shut down and the terminal state is restored to its - state when the ``brick`` event loop began execution. When it finishes - executing, the event loop will be resumed using the returned state - value. This is useful for situations where your program needs to - suspend your interface and execute some other program that needs to - gain control of the terminal (such as an external editor). +* ``Brick.Main.halt``: halt the event loop. The application state as it + exists after the event handler completes is returned to the caller + of ``defaultMain`` or ``customMain``. +* ``Brick.Main.continueWithoutRedraw``: continue executing the event + loop, but do not redraw the screen using the new state before waiting + for another input event. This is faster than the default continue + behavior since it doesn't redraw the screen; it just leaves up the + previous screen contents. This function is only useful when you know + that your event handler's state change(s) won't cause anything on + the screen to change. Use this only when you are certain that no + redraw of the screen is needed *and* when you are trying to address a + performance problem. (See also `The Rendering Cache`_ for details on + how to deal with rendering performance issues.) -The ``EventM`` monad is the event-handling monad. This monad is a -transformer around ``IO`` so you are free to do I/O in this monad by -using ``liftIO``. Beyond I/O, this monad is used to make scrolling -requests to the renderer (see `Viewports`_) and obtain named extents -(see `Extents`_). Keep in mind that time spent blocking in your event -handler is time during which your UI is unresponsive, so consider this -when deciding whether to have background threads do work instead of -inlining the work in the event handler. +The ``EventM`` monad is a transformer around ``IO`` so I/O is possible +in this monad by using ``liftIO``. Keep in mind, however, that event +handlers should execute as quickly as possible to avoid introducing +screen redraw latency. Consider using background threads to work +asynchronously when handling an event would otherwise cause redraw +latency. -Widget Event Handlers -********************* +``EventM`` is also used to make scrolling requests to the renderer (see +`Viewports`_), obtain named extents (see `Extents`_), and other duties. -Event handlers are responsible for transforming the application state. -While you can use ordinary methods to do this such as pattern matching -and pure function calls, some widget state types such as the ones -provided by the ``Brick.Widgets.List`` and ``Brick.Widgets.Edit`` -modules provide their own widget-specific event-handling functions. -For example, ``Brick.Widgets.Edit`` provides ``handleEditorEvent`` and -``Brick.Widgets.List`` provides ``handleListEvent``. +Event Handlers for Component State +********************************** -Since these event handlers run in ``EventM``, they have access to -rendering viewport states via ``Brick.Main.lookupViewport`` and the -``IO`` monad via ``liftIO``. +The top-level ``appHandleEvent`` handler is responsible for managing +the application state, but it also needs to be able to update the state +associated with UI components such as those that come with Brick. -To use these handlers in your program, invoke them on the relevant piece -of state in your application state. In the following example we use an -``Edit`` state from ``Brick.Widgets.Edit``: +For example, consider an application that uses Brick's built-in text +editor from ``Brick.Widgets.Edit``. The built-in editor is similar to +the main application in that it has three important elements: -.. code:: haskell +* The editor state of type ``Editor t n``: this stores the editor's + contents, cursor position, etc. +* The editor's drawing function, ``renderEditor``: this is responsible + for drawing the editor in the UI. +* The editor's event handler, ``handleEditorEvent``: this is responsible + for updating the editor's contents and cursor position in response to + key events. - data Name = Edit1 - type MyState = Editor String Name +To use the built-in editor, the application must: - myEvent :: MyState -> BrickEvent n e -> EventM Name (Next MyState) - myEvent s (VtyEvent e) = continue =<< handleEditorEvent e s +* Embed an ``Editor t n`` somewhere in the application state ``s``, +* Render the editor's state at the appropriate place in ``appDraw`` with + ``renderEditor``, and +* Dispatch events to the editor in the ``appHandleEvent`` with + ``handleEditorEvent``. -This pattern works well enough when your application state has an -event handler as shown in the ``Edit`` example above, but it can -become unpleasant if the value on which you want to invoke a handler -is embedded deeply within your application state. If you have chosen -to generate lenses for your application state fields, you can use the -convenience function ``handleEventLensed`` by specifying your state, a -lens, and the event: +An example application state using an editor might look like this: .. code:: haskell - data Name = Edit1 - data MyState = MyState { _theEdit :: Editor String Name - } + data MyState n = MyState { _editor :: Editor Text n } makeLenses ''MyState - myEvent :: MyState -> BrickEvent n e -> EventM Name (Next MyState) - myEvent s (VtyEvent e) = continue =<< handleEventLensed s theEdit handleEditorEvent e +This declares the ``MyState`` type with an ``Editor`` contained within +it and uses Template Haskell to generate a lens, ``editor``, to allow us +to easily update the editor state in our event handler. -You might consider that preferable to the desugared version: +To dispatch events to the ``editor`` we'd start by writing the +application event handler: .. code:: haskell - myEvent :: MyState -> BrickEvent n e -> EventM Name (Next MyState) - myEvent s (VtyEvent e) = do - newVal <- handleEditorEvent e (s^.theEdit) - continue $ s & theEdit .~ newVal + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + ... +But there's a problem: ``handleEditorEvent``'s type indicates that it +can only run over a state of type ``Editor t n``, but our handler runs +on ``MyState``. Specifically, ``handleEditorEvent`` has this type: + +.. code:: haskell + + handleEditorEvent :: BrickEvent n e -> EventM n (Editor t n) () + +This means that to use ``handleEditorEvent``, it must be composed +into the application's event handler, but since the state types ``s`` +and ``Editor t n`` do not match, we need a way to compose these event +handlers. There are two ways to do this: + +* Use ``Lens.Micro.Mtl.zoom`` from the ``microlens-mtl`` package + (re-exported by ``Brick.Types`` for convenience). This function is + required when you want to change the state type to a field embedded in + your application state using a lens. For example: + +.. code:: haskell + + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + zoom editor $ handleEditorEvent e + +* Use ``Brick.Types.nestEventM``: this function lets you provide a state + value and run ``EventM`` using that state. The following + ``nestEventM`` example is equivalent to the ``zoom`` example above: + +.. code:: haskell + + import Lens.Micro (_1) + import Lens.Micro.Mtl (use, (.=)) + + handleEvent :: BrickEvent n e -> EventM n MyState () + handleEvent e = do + editorState <- use editor + (newEditorState, ()) <- nestEventM editorState $ do + handleEditorEvent e + editor .= newEditorState + +The ``zoom`` function, together with lenses for your application state's +fields, is by far the best way to manage your state in ``EventM``. As +you can see from the examples above, the ``zoom`` approach avoids a lot +of boilerplate. The ``nestEventM`` approach is provided in cases where +the state that you need to mutate is not easily accessed by ``zoom``. + +Finally, if you prefer to avoid the use of lenses, you can always use +the ``MonadState`` API to get, put, and modify your state. Keep in +mind that the ``MonadState`` approach will still require the use of +``nestEventM`` when events scoped to widget states such as ``Editor`` +need to be handled. + Using Your Own Event Type ************************* @@ -327,13 +389,13 @@ 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 look for ``AppEvent`` values in the event +events we'll just need to check for ``AppEvent`` values in the event handler: .. code:: haskell - myEvent :: s -> BrickEvent n CounterEvent -> EventM n (Next s) - myEvent s (AppEvent (Counter i)) = ... + myEvent :: BrickEvent n CounterEvent -> EventM n s () + myEvent (AppEvent (Counter i)) = ... The next step is to actually *generate* our custom events and inject them into the ``brick`` event stream so they make it to the @@ -348,7 +410,7 @@ main :: IO () main = do eventChan <- Brick.BChan.newBChan 10 - let buildVty = Graphics.Vty.mkVty Graphics.Vty.defaultConfig + let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig initialVty <- buildVty finalState <- customMain initialVty buildVty (Just eventChan) app initialState @@ -357,7 +419,11 @@ The ``customMain`` function lets us have control over how the ``vty`` library is initialized *and* how ``brick`` gets custom events to give to our event handler. ``customMain`` is the entry point into ``brick`` when -you need to use your own event type as shown here. +you need to use your own event type as shown here. In this example we're +using ``mkVty`` provided by the ``vty-crossplatform`` package, which +provides build-time support for both Unix and Windows. If you prefer, +you can use either the ``vty-unix`` package or the ``vty-windows`` +package directly instead if you only want to support one platform. With all of this in place, sending our custom events to the event handler is straightforward: @@ -384,8 +450,8 @@ your event handler when choosing the channel capacity and design event producers so that they can block if the channel is full. -Starting up: appStartEvent -************************** +``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 @@ -396,16 +462,17 @@ .. code:: haskell - appStartEvent :: s -> EventM n s + appStartEvent :: EventM n s () -This function takes the initial application state and returns it in -``EventM``, possibly changing it and possibly making viewport requests. -This function is invoked once and only once, at application startup. -For more details, see `Viewports`_. You will probably just want to use -``return`` as the implementation of this function for most applications. +This function is a handler action to run on the initial application +state. This function is invoked once and only once, at application +startup. This might be a place to make initial viewport scroll requests +or make changes to the Vty environment. You will probably just want +to use ``return ()`` as the implementation of this function for most +applications. -appChooseCursor: Placing the Cursor ------------------------------------ +``appChooseCursor``: Placing the Cursor +--------------------------------------- The rendering process for a ``Widget`` may return information about where that widget would like to place the cursor. For example, a text @@ -462,9 +529,10 @@ .. code:: haskell - myApp = App { ... - , appChooseCursor = \_ -> showCursorNamed CustomName - } + myApp = + App { ... + , appChooseCursor = \_ -> showCursorNamed CustomName + } See the next section for more information on using names. @@ -515,9 +583,8 @@ .. code:: haskell - do - let vp = viewportScroll Viewport1 - vScrollBy vp 1 + let vp = viewportScroll Viewport1 + vScrollBy vp 1 The solution is to ensure that for a given resource type (in this case viewport), a unique name is assigned in each use. @@ -530,10 +597,10 @@ ui = (viewport Viewport1 Vertical $ str "Foo") <+> (viewport Viewport2 Vertical $ str "Bar") <+> -appAttrMap: Managing Attributes -------------------------------- +``appAttrMap``: Managing Attributes +----------------------------------- -In ``brick`` we use an *attribute map* to assign attibutes to elements +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. @@ -620,7 +687,7 @@ 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 +``Brick.Widgets.Center.hCenter`` function centers a widget and is ``Greedy`` horizontally and defers to the widget it centers for vertical growth behavior. @@ -756,27 +823,71 @@ , (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. +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. -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: +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.Widgets.Core.updateAttrMap`` -* ``Brick.Widgets.Core.forceAttr`` -* ``Brick.Widgets.Core.withDefAttr`` -* ``Brick.Widgets.Core.overrideAttr`` +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 ================ @@ -784,7 +895,7 @@ follows: * The application provides a default theme built in to the program. -* The application customizes the them by loading theme customizations +* 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. @@ -867,16 +978,20 @@ If the theme is further customized at runtime, any changes can be saved with ``Brick.Themes.saveCustomizations``. -Wide Character Support and the TextWidth class -============================================== +Wide Character Support and the ``TextWidth`` class +================================================== -Brick supports rendering wide characters in all widgets, and the brick -editor supports entering and editing wide characters. Wide characters -are those such as many Asian characters and emoji that need more than -a single terminal column to be displayed. Brick relies on Vty's use of -the `utf8proc`_ library to determine the column width of each character -rendered. +Brick attempts to support rendering wide characters in all widgets, +and the brick editor supports entering and editing wide characters. +Wide characters are those such as many Asian characters and emoji +that need more than a single terminal column to be displayed. +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 @@ -886,26 +1001,28 @@ let width = Data.Text.length t -because if the string contains any wide characters, their widths -will not be counted properly. In order to get this right, use the -``TextWidth`` type class to compute the width: +If the string contains any wide characters, their widths will not be +counted properly. In order to get this right, use the ``TextWidth`` type +class to compute the width: .. code:: haskell let width = Brick.Widgets.Core.textWidth t -The ``TextWidth`` type class uses Vty's character width routine (and -thus ``utf8proc``) to compute the correct width. If you need to compute -the width of a single character, use ``Graphics.Text.wcwidth``. +The ``TextWidth`` type class uses Vty's character width routine to +compute the width by looking up the string's 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 it -in an event handler. In the following example, the application needs to -know where the bordered box containing "Foo" is rendered: +When an application needs to know where a particular widget was drawn +by the renderer, the application can request that the renderer record +the *extent* of the widget--its upper-left corner and size--and provide +access to it in an event handler. Extents are represented using Brick's +``Brick.Types.Extent`` type. In the following example, the application +needs to know where the bordered box containing "Foo" is rendered: .. code:: haskell @@ -924,22 +1041,21 @@ reportExtent FooBox $ border $ str "Foo" -Now, whenever the ``ui`` is rendered, the location and size of the -bordered box containing "Foo" will be recorded. We can then look it up -in event handlers in ``EventM``: +Now, whenever the ``ui`` is rendered, the extent of the bordered box +containing "Foo" will be recorded. We can then look it up in event +handlers in ``EventM``: .. code:: haskell - do - mExtent <- Brick.Main.lookupExtent FooBox - case mExtent of + mExtent <- Brick.Main.lookupExtent FooBox + case mExtent of Nothing -> ... - Just (Extent _ upperLeft (width, height) offset) -> ... + Just (Extent _ upperLeft (width, height)) -> ... Paste Support ============= -Some terminal emulators support "bracketed paste" support. This feature +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 @@ -957,10 +1073,10 @@ import qualified Graphics.Vty as V do - vty <- Brick.Main.getVtyHandle - let output = V.outputIface vty - when (V.supportsMode output V.BracketedPaste) $ - liftIO $ V.setMode output V.BracketedPaste True + vty <- Brick.Main.getVtyHandle + let output = V.outputIface vty + when (V.supportsMode output V.BracketedPaste) $ + liftIO $ V.setMode output V.BracketedPaste True Once enabled, paste mode will generate Vty ``EvPaste`` events. These events will give you the entire pasted content as a ``ByteString`` which @@ -978,10 +1094,10 @@ .. code:: haskell do - vty <- Brick.Main.getVtyHandle - let output = outputIface vty - when (supportsMode output Mouse) $ - liftIO $ setMode output Mouse True + vty <- Brick.Main.getVtyHandle + let output = outputIface vty + when (supportsMode output Mouse) $ + liftIO $ setMode output Mouse True Bear in mind that some terminals do not support mouse interaction, so use Vty's ``getModeStatus`` to find out whether your terminal will @@ -1002,7 +1118,7 @@ .. code:: haskell - handleEvent s (VtyEvent (EvMouseDown col row button mods) = ... + handleEvent (VtyEvent (EvMouseDown col row button mods) = ... Brick Mouse Events ------------------ @@ -1012,27 +1128,60 @@ language. The disadvantage to the low-level interface described above is that you still need to determine *what* was clicked, i.e., the part of the interface that was under the mouse cursor. There are two ways to do -this with ``brick``: with *extent checking* and *click reporting*. +this with ``brick``: with *click reporting* and *extent checking*. +Click reporting +*************** + +The *click reporting* approach is the most high-level approach offered +by ``brick`` and the one that we recommend you use. In this approach, +we use ``Brick.Widgets.Core.clickable`` when drawing the interface to +request that a given widget generate ``MouseDown`` and ``MouseUp`` +events when it is clicked. + +.. code:: haskell + + data Name = MyButton + + ui :: Widget Name + ui = center $ + clickable MyButton $ + border $ + str "Click me" + + handleEvent (MouseDown MyButton button modifiers coords) = ... + handleEvent (MouseUp MyButton button coords) = ... + +This approach enables event handlers to use pattern matching to check +for mouse clicks on specific regions; this uses `Extent checking`_ +under the hood but makes it possible to denote which widgets are +clickable in the interface description. The event's click coordinates +are local to the widget being clicked. In the above example, a click +on the upper-left corner of the border would result in coordinates of +``(0,0)``. + Extent checking *************** The *extent checking* approach entails requesting extents (see `Extents`_) for parts of your interface, then checking the Vty mouse -click event's coordinates against one or more extents. +click event's coordinates against one or more extents. This approach +is slightly lower-level than the direct mouse click reporting approach +above but is provided in case you need more control over how mouse +clicks are dealt with. The most direct way to do this is to check a specific extent: .. code:: haskell - handleEvent s (VtyEvent (EvMouseDown col row _ _)) = do - mExtent <- lookupExtent SomeExtent - case mExtent of - Nothing -> continue s - Just e -> do - if Brick.Main.clickedExtent (col, row) e - then ... - else ... + handleEvent (VtyEvent (EvMouseDown col row _ _)) = do + mExtent <- lookupExtent SomeExtent + case mExtent of + Nothing -> return () + Just e -> do + if Brick.Main.clickedExtent (col, row) e + then ... + else ... This approach works well enough if you know which extent you're interested in checking, but what if there are many extents and you @@ -1041,10 +1190,10 @@ .. code:: haskell - handleEvent s (VtyEvent (EvMouseDown col row _ _)) = do - extents <- Brick.Main.findClickedExtents (col, row) - -- Then check to see if a specific extent is in the list, or just - -- take the first one in the list. + handleEvent (VtyEvent (EvMouseDown col row _ _)) = do + extents <- Brick.Main.findClickedExtents (col, row) + -- Then check to see if a specific extent is in the list, or just + -- take the first one in the list. This approach finds all clicked extents and returns them in a list with the following properties: @@ -1058,35 +1207,6 @@ As a result, the extents are ordered in a natural way, starting with the most specific extents and proceeding to the most general. -Click reporting -*************** - -The *click reporting* approach is the most high-level approach -offered by ``brick``. When rendering the interface we use -``Brick.Widgets.Core.clickable`` to request that a given widget generate -``MouseDown`` and ``MouseUp`` events when it is clicked. - -.. code:: haskell - - data Name = MyButton - - ui :: Widget Name - ui = center $ - clickable MyButton $ - border $ - str "Click me" - - handleEvent s (MouseDown MyButton button modifiers coords) = ... - handleEvent s (MouseUp MyButton button coords) = ... - -This approach enables event handlers to use pattern matching to check -for mouse clicks on specific regions; this uses extent reporting -under the hood but makes it possible to denote which widgets are -clickable in the interface description. The event's click coordinates -are local to the widget being clicked. In the above example, a click -on the upper-left corner of the border would result in coordinates of -``(0,0)``. - Viewports ========= @@ -1159,14 +1279,14 @@ .. code:: haskell - hScrollPage :: Direction -> EventM n () - hScrollBy :: Int -> EventM n () - hScrollToBeginning :: EventM n () - hScrollToEnd :: EventM n () - vScrollPage :: Direction -> EventM n () - vScrollBy :: Int -> EventM n () - vScrollToBeginning :: EventM n () - vScrollToEnd :: EventM n () + hScrollPage :: Direction -> EventM n s () + hScrollBy :: Int -> EventM n s () + hScrollToBeginning :: EventM n s () + hScrollToEnd :: EventM n s () + vScrollPage :: Direction -> EventM n s () + vScrollBy :: Int -> EventM n s () + vScrollToBeginning :: EventM n s () + vScrollToEnd :: EventM n s () In each case the scrolling function scrolls the viewport by the specified amount in the specified direction; functions prefixed with @@ -1182,11 +1302,10 @@ .. code:: haskell - myHandler :: s -> e -> EventM n (Next s) - myHandler s e = do + myHandler :: e -> EventM n s () + myHandler e = do let vp = viewportScroll Viewport1 hScrollBy vp 1 - continue s Scrolling Viewports With Visibility Requests -------------------------------------------- @@ -1205,7 +1324,7 @@ -- Assuming that App uses 'Name' for its resource names: data Name = Viewport1 let w = viewport Viewport1 Horizontal $ - (visible $ str "Hello," <+> (str " world!") + (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 @@ -1225,6 +1344,29 @@ 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 --------------------- @@ -1265,7 +1407,7 @@ A Form Example -------------- -Let's look at an example data type that we'd want to use as the +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. @@ -1352,9 +1494,14 @@ 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 approprate type +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 @@ -1390,7 +1537,7 @@ .. code:: haskell (str "Name: " <+>) @@= - editTextField name NameField (Just 1) + editTextField name NameField (Just 1) Now when we invoke ``renderForm`` on a form using the above example, we'll see a ``"Name:"`` label to the left of the editor field for @@ -1414,7 +1561,7 @@ * ``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 valid validation. + field that has user input that has invalid validation. Your application should set both of these. Some good mappings in the attribute map are: @@ -1425,14 +1572,14 @@ Handling Form Events -------------------- -Handling form events is easy: we just call -``Brick.Forms.handleFormEvent`` with the ``BrickEvent`` and the -``Form``. This automatically dispatches input events to the -currently-focused input field, and it also manages focus changes with -``Tab`` and ``Shift-Tab`` keybindings. (For details on all of its -behaviors, see the Haddock documentation for ``handleFormEvent``.) It's -still up to the application to decide when events should go to the form -in the first place. +Handling form events is easy: we just use ``zoom`` to call +``Brick.Forms.handleFormEvent`` with the ``BrickEvent`` and a lens +to access the ``Form`` in the application state. This automatically +dispatches input events to the currently-focused input field, and it +also manages focus changes with ``Tab`` and ``Shift-Tab`` keybindings. +(For details on all of its behaviors, see the Haddock documentation for +``handleFormEvent``.) It's still up to the application to decide when +events should go to the form in the first place. Since the form field handlers take ``BrickEvent`` values, that means that custom fields could even handle application-specific events (of the @@ -1478,6 +1625,161 @@ 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 =============== @@ -1500,7 +1802,7 @@ 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 to so that it connects +the Brick will re-draw one of the characters so that it connects seamlessly with the adjacent border. How Joining Works @@ -1664,6 +1966,14 @@ so by consulting the ``ctxDynBorders`` field of the rendering context before writing to your ``Result``'s ``borders`` field. +Animations +========== + +Brick provides animation support in ``Brick.Animation``. See the Haddock +documentation in that module for a complete explanation of the API; see +``programs/AnimationDemo.hs`` (``brick-animation-demo``) for a working +example. + The Rendering Cache =================== @@ -1683,8 +1993,8 @@ border $ str "This will be cached" -In the example above, the first time the ``border $ str "This will be -cached"`` widget is rendered, the resulting Vty image will be stored +In the example above, the first time the ``border $ str "This will be cached"`` +widget is rendered, the resulting Vty image will be stored in the rendering cache under the key ``ExpensiveThing``. On subsequent renderings the cached Vty image will be used instead of re-rendering the widget. This example doesn't need caching to improve performance, but @@ -1699,12 +2009,12 @@ .. code:: haskell - handleEvent s ... = do - -- Invalidate just a single cache entry: - Brick.Main.invalidateCacheEntry ExpensiveThing + handleEvent ... = do + -- Invalidate just a single cache entry: + Brick.Main.invalidateCacheEntry ExpensiveThing - -- Invalidate the entire cache (useful on a resize): - Brick.Main.invalidateCache + -- Invalidate the entire cache (useful on a resize): + Brick.Main.invalidateCache Implementing Custom Widgets =========================== @@ -1845,4 +2155,3 @@ .. _Hackage: http://hackage.haskell.org/ .. _microlens: http://hackage.haskell.org/package/microlens .. _bracketed paste mode: https://cirw.in/blog/bracketed-paste -.. _utf8proc: http://julialang.org/utf8proc/ diff --git a/docs/samtay-tutorial.md b/docs/samtay-tutorial.md deleted file mode 100644 --- a/docs/samtay-tutorial.md +++ /dev/null @@ -1,546 +0,0 @@ - -# Brick Tutorial by Samuel Tay - -This tutorial was written by Samuel Tay, Copyright 2017 -(https://github.com/samtay, https://samtay.github.io/). It is provided -as part of the brick distribution with permission. - -## Introduction - -I'm going to give a short introduction to -[brick](https://hackage.haskell.org/package/brick), a Haskell library -for building terminal user interfaces. So far I've used `brick` to -implement [Conway's Game of Life](https://github.com/samtay/conway) and -a [Tetris clone](https://github.com/samtay/tetris). I'll explain the -basics, walk through an example [snake](https://github.com/samtay/snake) -application, and then explain some more complicated scenarios. - -The first thing I'll say is that this package has some of the most -impressive documentation and resources, which makes it easy to figure -out pretty much anything you need to do. I'll try to make this useful, -but I imagine if you're reading this then it is mostly being used as a -reference in addition to the existing resources: - -1. [Demo programs](https://github.com/jtdaugherty/brick/tree/master/programs) -(clone down to explore the code and run them locally) -2. [User guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst) -3. [Haddock docs](https://hackage.haskell.org/package/brick-0.18) -4. [Google group](https://groups.google.com/forum/#!forum/brick-users) - -### The basic idea - -`brick` is very declarative. Once your base application logic is in -place, the interface is generally built by two functions: drawing and -handling events. The drawing function - -```haskell -appDraw :: s -> [Widget n] -``` - -takes your app state `s` and produces the visuals `[Widget n]`. The -handler - -```haskell -appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) -``` - -takes your app state, an event (e.g. user presses the `'m'` key), and -produces the resulting app state. *That's pretty much it.* - -## `snake` - -We're going to build the [classic -snake](https://en.wikipedia.org/wiki/Snake_(video_game)) game that you -might recall from arcades or the first cell phones. The full source code -is [here](https://github.com/samtay/snake). This is the end product: - -![](snake-demo.gif) - -### Structure of the app - -The library makes it easy to separate the concerns of your application -and the interface; I like to have a module with all of the core business -logic that exports the core state of the app and functions for modifying -it, and then have an interface module that just handles the setup, -drawing, and handling events. So let's just use the `simple` stack -template and add two modules - -``` -├── LICENSE -├── README.md -├── Setup.hs -├── snake.cabal -├── src -│   ├── Main.hs -│   ├── Snake.hs -│   └── UI.hs -└── stack.yaml -``` - -and our dependencies to `test.cabal` - -```yaml -executable snake - hs-source-dirs: src - main-is: Main.hs - ghc-options: -threaded - exposed-modules: Snake - , UI - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , brick - , containers - , linear - , microlens - , microlens-th - , random -``` - -### `Snake` - -Since this tutorial is about `brick`, I'll elide most of the -implementation details of the actual game, but here are some of the key -types and scaffolding: - -```haskell -{-# LANGUAGE TemplateHaskell, FlexibleContexts #-} -module Snake where - -import Control.Applicative ((<|>)) -import Control.Monad (guard) -import Data.Maybe (fromMaybe) - -import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|)) -import qualified Data.Sequence as S -import Lens.Micro.TH (makeLenses) -import Lens.Micro ((&), (.~), (%~), (^.)) -import Linear.V2 (V2(..), _x, _y) -import System.Random (Random(..), newStdGen) - --- Types - -data Game = Game - { _snake :: Snake -- ^ snake as a sequence of points in R2 - , _dir :: Direction -- ^ direction - , _food :: Coord -- ^ location of the food - , _foods :: Stream Coord -- ^ infinite list of random food locations - , _dead :: Bool -- ^ game over flag - , _paused :: Bool -- ^ paused flag - , _score :: Int -- ^ score - , _frozen :: Bool -- ^ freeze to disallow duplicate turns - } deriving (Show) - -type Coord = V2 Int -type Snake = Seq Coord - -data Stream a = a :| Stream a - deriving (Show) - -data Direction - = North - | South - | East - | West - deriving (Eq, Show) -``` - -All of this is pretty self-explanatory, with the possible exception -of lenses if you haven't seen them. At first glance they may seem -complicated (and the underlying theory arguably is), but using them as -getters and setters is very straightforward. So, if you are following -along because you are writing a terminal app like this, I'd recommend -using them, but they are not required to use `brick`. - -Here are the core functions for playing the game: - -```haskell --- | Step forward in time -step :: Game -> Game -step g = fromMaybe g $ do - guard (not $ g ^. paused || g ^. dead) - let g' = g & frozen .~ False - return . fromMaybe (move g') $ die g' <|> eatFood g' - --- | Possibly die if next head position is disallowed -die :: Game -> Maybe Game - --- | Possibly eat food if next head position is food -eatFood :: Game -> Maybe Game - --- | Move snake along in a marquee fashion -move :: Game -> Game - --- | Turn game direction (only turns orthogonally) --- --- Implicitly unpauses yet freezes game -turn :: Direction -> Game -> Game - --- | Initialize a paused game with random food location -initGame :: IO Game -``` - -### `UI` - -To start, we need to determine what our `App s e n` type parameters are. -This will completely describe the interface application and be passed -to one of the library's `main` style functions for execution. Note that -`s` is the app state, `e` is an event type, and `n` is a resource name. -The `e` is abstracted so that we can provide custom events. The `n` -is usually a custom sum type called `Name` which allows us to *name* -particular viewports. This is important so that we can keep track of -where the user currently has *focus*, such as typing in one of two -textboxes; however, for this simple snake game we don't need to worry -about that. - -In simpler cases, the state `s` can directly coincide with a core -datatype such as our `Snake.Game`. In many cases however, it will be -necessary to wrap the core state within the ui state `s` to keep track -of things that are interface specific (more on this later). - -Let's write out our app definition and leave some undefined functions: - -```haskell -{-# LANGUAGE OverloadedStrings #-} -module UI where - -import Control.Monad (forever, void) -import Control.Monad.IO.Class (liftIO) -import Control.Concurrent (threadDelay, forkIO) -import Data.Maybe (fromMaybe) - -import Snake - -import Brick - ( App(..), AttrMap, BrickEvent(..), EventM, Next, Widget - , customMain, neverShowCursor - , continue, halt - , hLimit, vLimit, vBox, hBox - , padRight, padLeft, padTop, padAll, Padding(..) - , withBorderStyle - , str - , attrMap, withAttr, emptyWidget, AttrName, on, fg - , (<+>) - ) -import Brick.BChan (newBChan, writeBChan) -import qualified Brick.Widgets.Border as B -import qualified Brick.Widgets.Border.Style as BS -import qualified Brick.Widgets.Center as C -import qualified Graphics.Vty as V -import Data.Sequence (Seq) -import qualified Data.Sequence as S -import Linear.V2 (V2(..)) -import Lens.Micro ((^.)) - --- Types - --- | Ticks mark passing of time --- --- This is our custom event that will be constantly fed into the app. -data Tick = Tick - --- | Named resources --- --- Not currently used, but will be easier to refactor --- if we call this "Name" now. -type Name = () - -data Cell = Snake | Food | Empty - --- App definition - -app :: App Game Tick Name -app = App { appDraw = drawUI - , appChooseCursor = neverShowCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } - -main :: IO () -main = undefined - --- Handling events - -handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) -handleEvent = undefined - --- Drawing - -drawUI :: Game -> [Widget Name] -drawUI = undefined - -theMap :: AttrMap -theMap = undefined -``` - -#### Custom Events - -So far I've only used `brick` to make games which need to be redrawn -as time passes, with or without user input. This requires using -`Brick.customMain` with that `Tick` event type, and opening a forked -process to `forever` feed that event type into the channel. Since this -is a common scenario, there is a `Brick.BChan` module that makes this -pretty quick: - -```haskell -main :: IO () -main = do - chan <- newBChan 10 - forkIO $ forever $ do - writeBChan chan Tick - threadDelay 100000 -- decides how fast your game moves - g <- initGame - let buildVty = V.mkVty V.defaultConfig - initialVty <- buildVty - void $ customMain initialVty buildVty (Just chan) app g -``` - -We do need to import `Vty.Graphics` since `customMain` allows us -to specify a custom `IO Vty.Graphics.Vty` handle, but we're only -customizing the existence of the event channel `BChan Tick`. The app -is now bootstrapped, and all we need to do is implement `handleEvent`, -`drawUI`, and `theMap` (handles styling). - -#### Handling events - -Handling events is largely straightforward, and can be very clean when -your underlying application logic is taken care of in a core module. All -we do is essentially map events to the proper state modifiers. - -```haskell -handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) -handleEvent g (AppEvent Tick) = continue $ step g -handleEvent g (VtyEvent (V.EvKey V.KUp [])) = continue $ turn North g -handleEvent g (VtyEvent (V.EvKey V.KDown [])) = continue $ turn South g -handleEvent g (VtyEvent (V.EvKey V.KRight [])) = continue $ turn East g -handleEvent g (VtyEvent (V.EvKey V.KLeft [])) = continue $ turn West g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'k') [])) = continue $ turn North g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'j') [])) = continue $ turn South g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'l') [])) = continue $ turn East g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'h') [])) = continue $ turn West g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'r') [])) = liftIO (initGame) >>= continue -handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g -handleEvent g (VtyEvent (V.EvKey V.KEsc [])) = halt g -handleEvent g _ = continue g -``` - -It's probably obvious, but `continue` will continue execution with -the supplied state value, which is then drawn. We can also `halt` to -stop execution, which will essentially finish the evaluation of our -`customMain` and result in `IO Game`, where the resulting game is the -last value that we supplied to `halt`. - -#### Drawing - -Drawing is fairly simple as well but can require a good amount of code -to position things how you want them. I like to break up the visual -space into regions with drawing functions for each one. - -```haskell -drawUI :: Game -> [Widget Name] -drawUI g = - [ C.center $ padRight (Pad 2) (drawStats g) <+> drawGrid g ] - -drawStats :: Game -> Widget Name -drawStats = undefined - -drawGrid :: Game -> Widget Name -drawGrid = undefined -``` - -This will center the overall interface (`C.center`), put the stats and -grid widgets horizontally side by side (`<+>`), and separate them by a -2-character width (`padRight (Pad 2)`). - -Let's move forward with the stats column: - -```haskell -drawStats :: Game -> Widget Name -drawStats g = hLimit 11 - $ vBox [ drawScore (g ^. score) - , padTop (Pad 2) $ drawGameOver (g ^. dead) - ] - -drawScore :: Int -> Widget Name -drawScore n = withBorderStyle BS.unicodeBold - $ B.borderWithLabel (str "Score") - $ C.hCenter - $ padAll 1 - $ str $ show n - -drawGameOver :: Bool -> Widget Name -drawGameOver dead = - if dead - then withAttr gameOverAttr $ C.hCenter $ str "GAME OVER" - else emptyWidget - -gameOverAttr :: AttrName -gameOverAttr = "gameOver" -``` - -I'm throwing in that `hLimit 11` to prevent the widget greediness caused -by the outer `C.center`. I'm also using `vBox` to show some other -options of aligning widgets; `vBox` and `hBox` align a list of widgets -vertically and horizontally, respectfully. They can be thought of as -folds over the binary `<=>` and `<+>` operations. - -The score is straightforward, but it is the first border in -this tutorial. Borders are well documented in the [border -demo](https://github.com/jtdaugherty/brick/blob/master/programs/BorderDemo.hs) -and the Haddocks for that matter. - -We also only show the "game over" widget if the game is actually over. -In that case, we are rendering the string widget with the `gameOverAttr` -attribute name. Attribute names are basically type safe *names* that -we can assign to widgets to apply predetermined styles, similar to -assigning a class name to a div in HTML and defining the CSS styles for -that class elsewhere. - -Attribute names implement `IsString`, so they are easy to construct with -the `OverloadedStrings` pragma. - -Now for the main event: - -```haskell -drawGrid :: Game -> Widget Name -drawGrid g = withBorderStyle BS.unicodeBold - $ B.borderWithLabel (str "Snake") - $ vBox rows - where - rows = [hBox $ cellsInRow r | r <- [height-1,height-2..0]] - cellsInRow y = [drawCoord (V2 x y) | x <- [0..width-1]] - drawCoord = drawCell . cellAt - cellAt c - | c `elem` g ^. snake = Snake - | c == g ^. food = Food - | otherwise = Empty - -drawCell :: Cell -> Widget Name -drawCell Snake = withAttr snakeAttr cw -drawCell Food = withAttr foodAttr cw -drawCell Empty = withAttr emptyAttr cw - -cw :: Widget Name -cw = str " " - -snakeAttr, foodAttr, emptyAttr :: AttrName -snakeAttr = "snakeAttr" -foodAttr = "foodAttr" -emptyAttr = "emptyAttr" - -``` - -There's actually nothing new here! We've already covered all the -`brick` functions necessary to draw the grid. My approach to grids is -to render a square cell widget `cw` with different colors depending -on the cell state. The easiest way to draw a colored square is to -stick two characters side by side. If we assign an attribute with a -matching foreground and background, then it doesn't matter what the two -characters are (provided that they aren't some crazy Unicode characters -that might render to an unexpected size). However, if we want empty -cells to render with the same color as the user's default background -color, then spaces are a good choice. - -Finally, we'll define the attribute map: - -```haskell -theMap :: AttrMap -theMap = attrMap V.defAttr - [ (snakeAttr, V.blue `on` V.blue) - , (foodAttr, V.red `on` V.red) - , (gameOverAttr, fg V.red `V.withStyle` V.bold) - ] -``` - -Again, styles aren't terribly complicated, but it -will be one area where you might have to look in the -[vty](http://hackage.haskell.org/package/vty) package (specifically -[Graphics.Vty.Attributes](http://hackage.haskell.org/package/vty-5.15.1/docs/Graphics-Vty-Attributes.html)) to find what you need. - -Another thing to mention is that the attributes form a hierarchy and -can be combined in a parent-child relationship via `mappend`. I haven't -actually used this feature, but it does sound quite handy. For a more -detailed discussion see the -[Brick.AttrMap](https://hackage.haskell.org/package/brick-0.18/docs/Brick-AttrMap.html) haddocks. - -## Variable speed - -One difficult problem I encountered was implementing a variable speed in -the GoL. I could have just used the same approach above with the minimum -thread delay (corresponding to the maximum speed) and counted `Tick` -events, only issuing an actual `step` in the game when the modular count -of `Tick`s reached an amount corresponding to the current game speed, -but that's kind of an ugly approach. - -Instead, I reached out to the author and he advised me to use a `TVar` -within the app state. I had never used `TVar`, but it's pretty easy! - -```haskell -main :: IO () -main = do - chan <- newBChan 10 - tv <- atomically $ newTVar (spToInt initialSpeed) - forkIO $ forever $ do - writeBChan chan Tick - int <- atomically $ readTVar tv - threadDelay int - let buildVty = V.mkVty V.defaultConfig - initialVty <- buildVty - customMain initialVty buildVty (Just chan) app (initialGame tv) - >>= printResult -``` - -The `tv <- atomically $ newTVar (value :: a)` creates a new mutable -reference to a value of type `a`, i.e. `TVar a`, and returns it in `IO`. -In this case `value` is an `Int` which represents the delay between game -steps. Then in the forked process, we read the delay from the `TVar` -reference and use that to space out the calls to `writeBChan chan Tick`. - -I store that same `tv :: TVar Int` in the brick app state, so that the -user can change the speed: - -```haskell -handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) -handleEvent g (VtyEvent (V.EvKey V.KRight [V.MCtrl])) = handleSpeed g (+) -handleEvent g (VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = handleSpeed g (-) - -handleSpeed :: Game -> (Float -> Float -> Float) -> EventM n (Next Game) -handleSpeed g (+/-) = do - let newSp = validS $ (g ^. speed) +/- speedInc - liftIO $ atomically $ writeTVar (g ^. interval) (spToInt newSp) - continue $ g & speed .~ newSp - --- where - --- | Speed increments = 0.01 gives 100 discrete speed settings -speedInc :: Float -speedInc = 0.01 - --- | Game state -data Game = Game - { _board :: Board -- ^ Board state - , _time :: Int -- ^ Time elapsed - , _paused :: Bool -- ^ Playing vs. paused - , _speed :: Float -- ^ Speed in [0..1] - , _interval :: TVar Int -- ^ Interval kept in TVar - , _focus :: F.FocusRing Name -- ^ Keeps track of grid focus - , _selected :: Cell -- ^ Keeps track of cell focus - } -``` - -## Conclusion - -`brick` let's you build TUIs very quickly. I was able to write `snake` -along with this tutorial within a few hours. More complicated interfaces -can be tougher, but if you can successfully separate the interface and -core functionality, you'll have an easier time tacking on the frontend. - -Lastly, let me remind you to look in the -[demo programs](https://github.com/jtdaugherty/brick/tree/master/programs) -to figure stuff out, as *many* scenarios are covered throughout them. - -## Links -* [brick](https://hackage.haskell.org/package/brick) -* [snake](https://github.com/samtay/snake) -* [tetris](https://github.com/samtay/tetris) -* [conway](https://github.com/samtay/conway) diff --git a/programs/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 @@ -23,28 +23,28 @@ , modifyDefAttr ) import Brick.Util (on, fg) -import Brick.AttrMap (attrMap, AttrMap) +import Brick.AttrMap (attrMap, AttrMap, attrName) ui :: Widget n ui = vBox [ str "This text uses the global default attribute." - , withAttr "foundFull" $ + , withAttr (attrName "foundFull") $ str "Specifying an attribute name means we look it up in the attribute tree." - , (withAttr "foundFgOnly" $ - 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" $ + , 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 "linked" $ + , withAttr (attrName "linked") $ str "This text is hyperlinked in terminals that support hyperlinking." , str " " , hyperlink "http://www.google.com/" $ @@ -59,18 +59,19 @@ theMap :: AttrMap theMap = attrMap globalDefault - [ ("foundFull", white `on` green) - , ("foundFgOnly", fg red) - , ("general", yellow `on` black) - , ("general" <> "specific", fg cyan) - , ("linked", fg yellow `withURL` "http://www.google.com/") + [ (attrName "foundFull", white `on` green) + , (attrName "foundFgOnly", fg red) + , (attrName "general", yellow `on` black) + , (attrName "general" <> attrName "specific", + fg cyan) + , (attrName "linked", fg yellow `withURL` "http://www.google.com/") ] app :: App () e () app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const theMap , appChooseCursor = neverShowCursor } diff --git a/programs/BorderDemo.hs b/programs/BorderDemo.hs --- a/programs/BorderDemo.hs +++ b/programs/BorderDemo.hs @@ -1,11 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) #endif -import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Graphics.Vty as V @@ -16,16 +16,17 @@ ( Widget ) import Brick.Widgets.Core - ( (<=>) - , (<+>) + ( (<+>) , withAttr , vLimit , hLimit , hBox + , vBox , updateAttrMap , withBorderStyle , txt , str + , padLeftRight ) import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B @@ -65,20 +66,23 @@ B.borderWithLabel (str "label") $ vLimit 5 $ C.vCenter $ - txt $ " " <> styleName <> " style " + padLeftRight 2 $ + txt $ styleName <> " style" titleAttr :: A.AttrName -titleAttr = "title" +titleAttr = A.attrName "title" -borderMappings :: [(A.AttrName, V.Attr)] -borderMappings = +attrs :: [(A.AttrName, V.Attr)] +attrs = [ (B.borderAttr, V.yellow `on` V.black) + , (B.vBorderAttr, fg V.cyan) + , (B.hBorderAttr, fg V.magenta) , (titleAttr, fg V.cyan) ] colorDemo :: Widget () colorDemo = - updateAttrMap (A.applyAttrMappings borderMappings) $ + updateAttrMap (A.applyAttrMappings attrs) $ B.borderWithLabel (withAttr titleAttr $ str "title") $ hLimit 20 $ vLimit 5 $ @@ -87,13 +91,14 @@ ui :: Widget () ui = - hBox borderDemos - <=> B.hBorder - <=> colorDemo - <=> B.hBorderWithLabel (str "horizontal border label") - <=> (C.center (str "Left of vertical border") - <+> B.vBorder - <+> C.center (str "Right of vertical border")) + vBox [ hBox borderDemos + , B.hBorder + , colorDemo + , B.hBorderWithLabel (str "horizontal border label") + , (C.center (str "Left of vertical border") + <+> B.vBorder + <+> C.center (str "Right of vertical border")) + ] main :: IO () main = M.simpleMain ui diff --git a/programs/CacheDemo.hs b/programs/CacheDemo.hs --- a/programs/CacheDemo.hs +++ b/programs/CacheDemo.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Main where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - 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 @@ -17,7 +16,8 @@ , BrickEvent(..) ) import Brick.Widgets.Core - ( vBox + ( Padding(..) + , vBox , padTopBottom , withDefAttr , cached @@ -30,6 +30,7 @@ ) import Brick.AttrMap ( AttrName + , attrName , attrMap ) @@ -51,26 +52,26 @@ , padTopBottom 1 $ cached ExpensiveWidget $ withDefAttr emphAttr $ str $ "This widget is cached (state = " <> show i <> ")" - , padBottom (T.Pad 1) $ + , padBottom (Pad 1) $ withDefAttr emphAttr $ str $ "This widget is not cached (state = " <> show i <> ")" , hCenter $ str "Press 'i' to invalidate the cache," , str "'+' to change the state value, and" , str "'Esc' to quit." ] -appEvent :: Int -> BrickEvent Name e -> T.EventM Name (T.Next Int) -appEvent i (VtyEvent (V.EvKey (V.KChar '+') [])) = M.continue $ i + 1 -appEvent i (VtyEvent (V.EvKey (V.KChar 'i') [])) = M.invalidateCacheEntry ExpensiveWidget >> M.continue i -appEvent i (VtyEvent (V.EvKey V.KEsc [])) = M.halt i -appEvent i _ = M.continue i +appEvent :: BrickEvent Name e -> T.EventM Name Int () +appEvent (VtyEvent (V.EvKey (V.KChar '+') [])) = modify (+ 1) +appEvent (VtyEvent (V.EvKey (V.KChar 'i') [])) = M.invalidateCacheEntry ExpensiveWidget +appEvent (VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () emphAttr :: AttrName -emphAttr = "emphasis" +emphAttr = attrName "emphasis" app :: M.App Int e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const $ attrMap V.defAttr [(emphAttr, V.white `on` V.blue)] , M.appChooseCursor = M.neverShowCursor diff --git a/programs/CroppingDemo.hs b/programs/CroppingDemo.hs 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 @@ -3,8 +3,9 @@ {-# LANGUAGE CPP #-} module Main where -import Lens.Micro ((^.), (&), (.~), (%~)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void, forever) import Control.Concurrent (threadDelay, forkIO) #if !(MIN_VERSION_base(4,11,0)) @@ -16,8 +17,7 @@ import Brick.Main ( App(..) , showFirstCursor - , customMain - , continue + , customMainWithDefaultVty , halt ) import Brick.AttrMap @@ -25,7 +25,6 @@ ) import Brick.Types ( Widget - , Next , EventM , BrickEvent(..) ) @@ -50,14 +49,15 @@ <=> (str $ "Counter value is: " <> (show $ st^.stCounter)) -appEvent :: St -> BrickEvent () CustomEvent -> EventM () (Next St) -appEvent st e = +appEvent :: BrickEvent () CustomEvent -> EventM () St () +appEvent e = case e of - VtyEvent (V.EvKey V.KEsc []) -> halt st - VtyEvent _ -> continue $ st & stLastBrickEvent .~ (Just e) - AppEvent Counter -> continue $ st & stCounter %~ (+1) - & stLastBrickEvent .~ (Just e) - _ -> continue st + VtyEvent (V.EvKey V.KEsc []) -> halt + VtyEvent _ -> stLastBrickEvent .= (Just e) + AppEvent Counter -> do + stCounter %= (+1) + stLastBrickEvent .= (Just e) + _ -> return () initialState :: St initialState = @@ -70,7 +70,7 @@ App { appDraw = drawUI , appChooseCursor = showFirstCursor , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] } @@ -78,10 +78,9 @@ main = do chan <- newBChan 10 - forkIO $ forever $ do + void $ forkIO $ forever $ do writeBChan chan Counter threadDelay 1000000 - let buildVty = V.mkVty V.defaultConfig - initialVty <- buildVty - void $ customMain initialVty buildVty (Just chan) theApp initialState + (_, vty) <- customMainWithDefaultVty (Just chan) theApp initialState + V.shutdown vty 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 @@ -25,25 +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 -> BrickEvent () e -> T.EventM () (T.Next (D.Dialog Choice)) -appEvent d (VtyEvent 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 =<< D.handleDialogEvent ev d -appEvent d _ = M.continue d + V.EvKey V.KEsc [] -> M.halt + V.EvKey V.KEnter [] -> M.halt + _ -> D.handleDialogEvent ev +appEvent _ = return () -initialState :: D.Dialog Choice -initialState = D.dialog (Just "Title") (Just (0, choices)) 50 +initialState :: D.Dialog Choice Name +initialState = D.dialog (Just $ str "Title") (Just (RedButton, choices)) 50 where - choices = [ ("Red", Red) - , ("Blue", Blue) - , ("Green", Green) + choices = [ ("Red", RedButton, Red) + , ("Blue", BlueButton, Blue) + , ("Green", GreenButton, Green) ] theMap :: A.AttrMap @@ -53,12 +59,12 @@ , (D.buttonSelectedAttr, bg V.yellow) ] -theApp :: M.App (D.Dialog Choice) e () +theApp :: M.App (D.Dialog Choice Name) e Name theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs --- a/programs/EditDemo.hs +++ b/programs/EditDemo.hs @@ -5,6 +5,7 @@ import Lens.Micro import Lens.Micro.TH +import Lens.Micro.Mtl import qualified Graphics.Vty as V import qualified Brick.Main as M @@ -47,18 +48,19 @@ str " " <=> str "Press Tab to switch between editors, Esc to quit." -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st (T.VtyEvent ev) = - case ev of - V.EvKey V.KEsc [] -> M.halt st - V.EvKey (V.KChar '\t') [] -> M.continue $ st & focusRing %~ F.focusNext - V.EvKey V.KBackTab [] -> M.continue $ st & focusRing %~ F.focusPrev - - _ -> M.continue =<< case F.focusGetCurrent (st^.focusRing) of - Just Edit1 -> T.handleEventLensed st edit1 E.handleEditorEvent ev - Just Edit2 -> T.handleEventLensed st edit2 E.handleEditorEvent ev - Nothing -> return st -appEvent st _ = M.continue st +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = + M.halt +appEvent (T.VtyEvent (V.EvKey (V.KChar '\t') [])) = + focusRing %= F.focusNext +appEvent (T.VtyEvent (V.EvKey V.KBackTab [])) = + focusRing %= F.focusPrev +appEvent ev = do + r <- use focusRing + case F.focusGetCurrent r of + Just Edit1 -> zoom edit1 $ E.handleEditorEvent ev + Just Edit2 -> zoom edit2 $ E.handleEditorEvent ev + Nothing -> return () initialState :: St initialState = @@ -80,7 +82,7 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = appCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/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 --- a/programs/FileBrowserDemo.hs +++ b/programs/FileBrowserDemo.hs @@ -8,10 +8,11 @@ #endif import qualified Graphics.Vty as V +import Control.Monad.State (get) import qualified Data.Text as Text import qualified Brick.Main as M import qualified Brick.Widgets.List as L -import Brick.AttrMap (AttrName) +import Brick.AttrMap (AttrName, attrName) import Brick.Types ( Widget , BrickEvent(..) @@ -27,8 +28,9 @@ ( vBox, (<=>), padTop , hLimit, vLimit, txt , withDefAttr, emptyWidget + , Padding(..) ) -import Brick.Widgets.FileBrowser as FB +import qualified Brick.Widgets.FileBrowser as FB import qualified Brick.AttrMap as A import Brick.Util (on, fg) import qualified Brick.Types as T @@ -36,7 +38,7 @@ data Name = FileBrowser1 deriving (Eq, Show, Ord) -drawUI :: FileBrowser Name -> [Widget Name] +drawUI :: FB.FileBrowser Name -> [Widget Name] drawUI b = [center $ ui <=> help] where ui = hCenter $ @@ -44,8 +46,8 @@ hLimit 50 $ borderWithLabel (txt "Choose a file") $ FB.renderFileBrowser True b - help = padTop (T.Pad 1) $ - vBox [ case fileBrowserException b of + help = padTop (Pad 1) $ + vBox [ case FB.fileBrowserException b of Nothing -> emptyWidget Just e -> hCenter $ withDefAttr errorAttr $ txt $ Text.pack $ E.displayException e @@ -55,25 +57,27 @@ , hCenter $ txt "Esc: quit" ] -appEvent :: FB.FileBrowser Name -> BrickEvent Name e -> T.EventM Name (T.Next (FB.FileBrowser Name)) -appEvent b (VtyEvent ev) = +appEvent :: BrickEvent Name e -> T.EventM Name (FB.FileBrowser Name) () +appEvent (VtyEvent ev) = do + b <- get case ev of - V.EvKey V.KEsc [] | not (fileBrowserIsSearching b) -> - M.halt b + V.EvKey V.KEsc [] | not (FB.fileBrowserIsSearching b) -> + M.halt _ -> do - b' <- FB.handleFileBrowserEvent ev b + FB.handleFileBrowserEvent ev -- If the browser has a selected file after handling the -- event (because the user pressed Enter), shut down. case ev of - V.EvKey V.KEnter [] -> - case fileBrowserSelection b' of - [] -> M.continue b' - _ -> M.halt b' - _ -> M.continue b' -appEvent b _ = M.continue b + V.EvKey V.KEnter [] -> do + b' <- get + case FB.fileBrowserSelection b' of + [] -> return () + _ -> M.halt + _ -> return () +appEvent _ = return () errorAttr :: AttrName -errorAttr = "error" +errorAttr = attrName "error" theMap :: A.AttrMap theMap = A.attrMap V.defAttr @@ -90,12 +94,12 @@ , (errorAttr, fg V.red) ] -theApp :: M.App (FileBrowser Name) e Name +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.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/FillDemo.hs b/programs/FillDemo.hs --- a/programs/FillDemo.hs +++ b/programs/FillDemo.hs @@ -4,11 +4,12 @@ import Brick.Widgets.Border ui :: Widget () -ui = vBox [ vLimitPercent 20 $ vBox [ str "This text is at the top." +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." + , str "This text is at the bottom with another fill beneath it." + , fill 'x' ] main :: IO () diff --git a/programs/FormDemo.hs b/programs/FormDemo.hs --- a/programs/FormDemo.hs +++ b/programs/FormDemo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Main where @@ -5,9 +6,13 @@ 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 @@ -109,29 +114,31 @@ app :: App (Form UserInfo e Name) e Name app = App { appDraw = draw - , appHandleEvent = \s ev -> + , appHandleEvent = \ev -> do + f <- gets formFocus case ev of - VtyEvent (V.EvResize {}) -> continue s - VtyEvent (V.EvKey V.KEsc []) -> halt s + VtyEvent (V.EvResize {}) -> return () + VtyEvent (V.EvKey V.KEsc []) -> halt -- Enter quits only when we aren't in the multi-line editor. VtyEvent (V.EvKey V.KEnter []) - | focusGetCurrent (formFocus s) /= Just AddressField -> halt s + | focusGetCurrent f /= Just AddressField -> halt _ -> do - s' <- handleFormEvent ev s + handleFormEvent ev -- Example of external validation: -- Require age field to contain a value that is at least 18. - continue $ setFieldValid ((formState s')^.age >= 18) AgeField s' + st <- gets formState + modify $ setFieldValid (st^.age >= 18) AgeField , appChooseCursor = focusRingCursor formFocus - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const theMap } main :: IO () main = do let buildVty = do - v <- V.mkVty =<< V.standardIOConfig + v <- mkVty V.defaultConfig V.setMode (V.outputIface v) V.Mouse True return v diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs --- a/programs/LayerDemo.hs +++ b/programs/LayerDemo.hs @@ -1,80 +1,108 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main where -import Lens.Micro ((^.), (&), (%~)) +#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 qualified Graphics.Vty as V import qualified Brick.Types as T -import Brick.Types (locationRowL, locationColumnL, Widget) +import Brick.Types (locationRowL, locationColumnL, Location(..), Widget) import qualified Brick.Main as M import qualified Brick.Widgets.Border as B 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 = [ C.centerLayer $ B.border $ str "This layer is centered but other\nlayers are placed underneath it." - , topLayer st - , bottomLayer st + , 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 -> T.BrickEvent () e -> T.EventM () (T.Next St) -appEvent st (T.VtyEvent (V.EvKey V.KDown [])) = - M.continue $ st & topLayerLocation.locationRowL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [])) = - M.continue $ st & topLayerLocation.locationRowL %~ (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KRight [])) = - M.continue $ st & topLayerLocation.locationColumnL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [])) = - M.continue $ st & topLayerLocation.locationColumnL %~ (subtract 1) +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = + middleLayerLocation.locationRowL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = + middleLayerLocation.locationRowL %= (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = + middleLayerLocation.locationColumnL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = + middleLayerLocation.locationColumnL %= (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationRowL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationRowL %~ (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationColumnL %~ (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = - M.continue $ st & bottomLayerLocation.locationColumnL %~ (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = + bottomLayerLocation.locationRowL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = + bottomLayerLocation.locationRowL %= (subtract 1) +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = + bottomLayerLocation.locationColumnL %= (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = + bottomLayerLocation.locationColumnL %= (subtract 1) -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st -appEvent st _ = M.continue st +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () -app :: M.App St e () +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 $ attrMap V.defAttr [] + , 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,10 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Main where import Lens.Micro ((^.)) +import Lens.Micro.Mtl import Control.Monad (void) +import Control.Monad.State (modify) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif @@ -48,26 +49,28 @@ , C.hCenter $ str "Press Esc to exit." ] -appEvent :: L.List () Char -> T.BrickEvent () e -> T.EventM () (T.Next (L.List () Char)) -appEvent l (T.VtyEvent e) = +appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Char) () +appEvent (T.VtyEvent e) = case e of - V.EvKey (V.KChar '+') [] -> - let el = nextElement (L.listElements l) - pos = Vec.length $ l^.(L.listElementsL) - in M.continue $ L.listInsert pos el l + V.EvKey (V.KChar '+') [] -> do + els <- use L.listElementsL + let el = nextElement els + pos = Vec.length els + modify $ L.listInsert pos el - V.EvKey (V.KChar '-') [] -> - case l^.(L.listSelectedL) of - Nothing -> M.continue l - Just i -> M.continue $ L.listRemove i l + V.EvKey (V.KChar '-') [] -> do + sel <- use L.listSelectedL + case sel of + Nothing -> return () + Just i -> modify $ L.listRemove i - V.EvKey V.KEsc [] -> M.halt l + V.EvKey V.KEsc [] -> M.halt - ev -> M.continue =<< L.handleListEvent ev l + ev -> L.handleListEvent ev where nextElement :: Vec.Vector Char -> Char nextElement v = fromMaybe '?' $ Vec.find (flip Vec.notElem v) (Vec.fromList ['a' .. 'z']) -appEvent l _ = M.continue l +appEvent _ = return () listDrawElement :: (Show a) => Bool -> a -> Widget () listDrawElement sel a = @@ -80,7 +83,7 @@ initialState = L.list () (Vec.fromList ['a','b','c']) 1 customAttr :: A.AttrName -customAttr = L.listSelectedAttr <> "custom" +customAttr = L.listSelectedAttr <> A.attrName "custom" theMap :: A.AttrMap theMap = A.attrMap V.defAttr @@ -94,7 +97,7 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/ListViDemo.hs b/programs/ListViDemo.hs --- a/programs/ListViDemo.hs +++ b/programs/ListViDemo.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Main where import Control.Monad (void) +import Control.Monad.State (modify) import Data.Maybe (fromMaybe) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif import qualified Graphics.Vty as V import Lens.Micro ((^.)) +import Lens.Micro.Mtl import qualified Brick.AttrMap as A import qualified Brick.Main as M @@ -39,26 +40,28 @@ , C.hCenter $ str "Press Esc to exit." ] -appEvent :: L.List () Char -> T.BrickEvent () e -> T.EventM () (T.Next (L.List () Char)) -appEvent l (T.VtyEvent e) = +appEvent :: T.BrickEvent () e -> T.EventM () (L.List () Char) () +appEvent (T.VtyEvent e) = case e of - V.EvKey (V.KChar '+') [] -> - let el = nextElement (L.listElements l) - pos = Vec.length $ l^.(L.listElementsL) - in M.continue $ L.listInsert pos el l + V.EvKey (V.KChar '+') [] -> do + els <- use L.listElementsL + let el = nextElement els + pos = Vec.length els + modify $ L.listInsert pos el - V.EvKey (V.KChar '-') [] -> - case l^.(L.listSelectedL) of - Nothing -> M.continue l - Just i -> M.continue $ L.listRemove i l + V.EvKey (V.KChar '-') [] -> do + sel <- use L.listSelectedL + case sel of + Nothing -> return () + Just i -> modify $ L.listRemove i - V.EvKey V.KEsc [] -> M.halt l + V.EvKey V.KEsc [] -> M.halt - ev -> M.continue =<< (L.handleListEventVi L.handleListEvent) ev l + ev -> L.handleListEventVi L.handleListEvent ev where nextElement :: Vec.Vector Char -> Char nextElement v = fromMaybe '?' $ Vec.find (flip Vec.notElem v) (Vec.fromList ['a' .. 'z']) -appEvent l _ = M.continue l +appEvent _ = return () listDrawElement :: (Show a) => Bool -> a -> Widget () listDrawElement sel a = @@ -71,7 +74,7 @@ initialState = L.list () (Vec.fromList ['a','b','c']) 1 customAttr :: A.AttrName -customAttr = L.listSelectedAttr <> "custom" +customAttr = L.listSelectedAttr <> A.attrName "custom" theMap :: A.AttrMap theMap = A.attrMap V.defAttr @@ -85,7 +88,7 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/MarkupDemo.hs b/programs/MarkupDemo.hs deleted file mode 100644 --- a/programs/MarkupDemo.hs +++ /dev/null @@ -1,45 +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 - , Padding(..) - ) -import Brick.Widgets.Core - ( (<=>) - , (<+>) - , padLeft - ) -import Brick.Util (on, fg) -import Brick.Markup (markup, (@?)) -import Brick.AttrMap (attrMap, AttrMap) -import Data.Text.Markup ((@@)) - -ui :: Widget () -ui = (m1 <=> m2) <+> (padLeft (Pad 1) m3) - where - m1 = markup $ ("Hello" @@ fg V.blue) <> ", " <> ("world!" @@ fg V.red) - m2 = markup $ ("Hello" @? "keyword1") <> ", " <> ("world!" @? "keyword2") - m3 = markup $ ("Hello," @? "keyword1") <> "\n" <> ("world!" @? "keyword2") - -theMap :: AttrMap -theMap = attrMap V.defAttr - [ ("keyword1", fg V.magenta) - , ("keyword2", V.white `on` V.blue) - ] - -app :: App () e () -app = - App { appDraw = const [ui] - , appHandleEvent = resizeOrQuit - , appAttrMap = const theMap - , appStartEvent = return - , appChooseCursor = neverShowCursor - } - -main :: IO () -main = defaultMain app () diff --git a/programs/MouseDemo.hs b/programs/MouseDemo.hs --- a/programs/MouseDemo.hs +++ b/programs/MouseDemo.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Applicative ((<$>)) -import Lens.Micro ((^.), (&), (.~), (%~)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl import Control.Monad (void) +import Control.Monad.Trans (liftIO) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) +#endif import qualified Graphics.Vty as V import qualified Brick.Types as T @@ -18,8 +21,6 @@ import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B import Brick.Widgets.Core -import Data.Text.Zipper (moveCursor) -import Data.Tuple (swap) data Name = Info | Button1 | Button2 | Button3 | Prose | TextBox deriving (Show, Ord, Eq) @@ -43,15 +44,15 @@ buttonLayer :: St -> Widget Name buttonLayer st = C.vCenterLayer $ - C.hCenterLayer (padBottom (T.Pad 1) $ str "Click a button:") <=> + C.hCenterLayer (padBottom (Pad 1) $ str "Click a button:") <=> C.hCenterLayer (hBox $ padLeftRight 1 <$> buttons) <=> C.hCenterLayer (padTopBottom 1 $ str "Or enter text and then click in this editor:") <=> C.hCenterLayer (vLimit 3 $ hLimit 50 $ E.renderEditor (str . unlines) True (st^.edit)) where buttons = mkButton <$> buttonData - buttonData = [ (Button1, "Button 1", "button1") - , (Button2, "Button 2", "button2") - , (Button3, "Button 3", "button3") + buttonData = [ (Button1, "Button 1", attrName "button1") + , (Button2, "Button 2", attrName "button2") + , (Button3, "Button 3", attrName "button3") ] mkButton (name, label, attr) = let wasClicked = (fst <$> st^.lastReportedClick) == Just name @@ -67,11 +68,7 @@ B.border $ C.hCenterLayer $ vLimit 8 $ - -- n.b. if clickable and viewport are inverted here, click event - -- coordinates will only identify the viewable range, not the actual - -- editor widget coordinates. viewport Prose Vertical $ - clickable Prose $ vBox $ map str $ lines (st^.prose) infoLayer :: St -> Widget Name @@ -79,38 +76,46 @@ c <- T.getContext let h = c^.T.availHeightL msg = case st^.lastReportedClick of - Nothing -> "nothing" - Just (name, T.Location l) -> show name <> " at " <> show l + 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 "info" $ - C.hCenter (str ("Last reported click: " <> msg)) + withDefAttr (attrName "info") $ + C.hCenter $ str msg -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st (T.MouseDown n _ _ loc) = do - let T.Location pos = loc - M.continue $ st & lastReportedClick .~ Just (n, loc) - & edit %~ E.applyEdit (if n == TextBox then moveCursor (swap pos) else id) -appEvent st (T.MouseUp _ _ _) = M.continue $ st & lastReportedClick .~ Nothing -appEvent st (T.VtyEvent (V.EvMouseUp _ _ _)) = M.continue $ st & lastReportedClick .~ Nothing -appEvent st (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) (-1) >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy (M.viewportScroll Prose) 1 >> M.continue st -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st -appEvent st (T.VtyEvent ev) = M.continue =<< T.handleEventLensed st edit E.handleEditorEvent ev -appEvent st _ = M.continue st +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent ev@(T.MouseDown n _ _ loc) = do + lastReportedClick .= Just (n, loc) + zoom edit $ E.handleEditorEvent ev +appEvent (T.MouseUp {}) = + lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvMouseUp {})) = + lastReportedClick .= Nothing +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = + M.vScrollBy (M.viewportScroll Prose) (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = + M.vScrollBy (M.viewportScroll Prose) 1 +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = + M.halt +appEvent ev = + zoom edit $ E.handleEditorEvent ev aMap :: AttrMap aMap = attrMap V.defAttr - [ ("info", V.white `on` V.magenta) - , ("button1", V.white `on` V.cyan) - , ("button2", V.white `on` V.green) - , ("button3", V.white `on` V.blue) + [ (attrName "info", V.white `on` V.magenta) + , (attrName "button1", V.white `on` V.cyan) + , (attrName "button2", V.white `on` V.green) + , (attrName "button3", V.white `on` V.blue) , (E.editFocusedAttr, V.black `on` V.yellow) ] app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = do + vty <- M.getVtyHandle + liftIO $ V.setMode (V.outputIface vty) V.Mouse True , M.appHandleEvent = appEvent , M.appAttrMap = const aMap , M.appChooseCursor = M.showFirstCursor @@ -118,30 +123,25 @@ main :: IO () main = do - let buildVty = do - v <- V.mkVty =<< V.standardIOConfig - V.setMode (V.outputIface v) V.Mouse True - return v - - initialVty <- buildVty - void $ M.customMain initialVty buildVty Nothing app $ St [] Nothing - "Try clicking on various UI elements.\n\ - \Observe that the click coordinates identify the\n\ - \underlying widget coordinates.\n\ - \\n\ - \Lorem ipsum dolor sit amet,\n\ - \consectetur adipiscing elit,\n\ - \sed do eiusmod tempor incididunt ut labore\n\ - \et dolore magna aliqua.\n\ - \ \n\ - \Ut enim ad minim veniam\n\ - \quis nostrud exercitation ullamco laboris\n\ - \nisi ut aliquip ex ea commodo consequat.\n\ - \\n\ - \Duis aute irure dolor in reprehenderit\n\ - \in voluptate velit esse cillum dolore eu fugiat nulla pariatur.\n\ - \\n\ - \Excepteur sint occaecat cupidatat not proident,\n\ - \sunt in culpa qui officia deserunt mollit\n\ - \anim id est laborum.\n" + 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 @@ -4,7 +4,6 @@ import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) import Brick.Types ( Widget - , Padding(..) ) import Brick.Widgets.Core ( vBox @@ -17,22 +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 = - 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" @@ -49,7 +49,7 @@ app = App { appDraw = const [ui] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] , appChooseCursor = neverShowCursor } diff --git a/programs/ProgressBarDemo.hs b/programs/ProgressBarDemo.hs --- a/programs/ProgressBarDemo.hs +++ b/programs/ProgressBarDemo.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} module Main where import Control.Monad (void) @@ -7,6 +8,8 @@ import Data.Monoid #endif import qualified Graphics.Vty as V +import Lens.Micro.Mtl +import Lens.Micro.TH import qualified Brick.AttrMap as A import qualified Brick.Main as M @@ -18,13 +21,16 @@ import Brick.Widgets.Core ( (<+>), (<=>) , str + , strWrap , updateAttrMap , overrideAttr ) import Brick.Util (fg, bg, on, clamp) -data MyAppState n = MyAppState { x, y, z :: Float } +data MyAppState n = MyAppState { _x, _y, _z :: Float, _showLabel :: Bool } +makeLenses ''MyAppState + drawUI :: MyAppState () -> [Widget ()] drawUI p = [ui] where @@ -33,37 +39,62 @@ (A.mapAttrNames [ (xDoneAttr, P.progressCompleteAttr) , (xToDoAttr, P.progressIncompleteAttr) ] - ) $ bar $ x p + ) $ bar $ _x p -- or use individual mapAttrName calls yBar = updateAttrMap (A.mapAttrName yDoneAttr P.progressCompleteAttr . A.mapAttrName yToDoAttr P.progressIncompleteAttr) $ - bar $ y p + bar $ _y p -- or use overrideAttr calls zBar = overrideAttr P.progressCompleteAttr zDoneAttr $ overrideAttr P.progressIncompleteAttr zToDoAttr $ - bar $ z p - lbl c = Just $ show $ fromEnum $ c * 100 + 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 "" <=> - str "Hit 'x', 'y', or 'z' to advance progress, or 'q' to quit" + (strWrap $ concat [ "Hit 'x', 'y', or 'z' to advance progress," + , "'t' to toggle labels, 'r' to revert values, " + , "'Ctrl + r' to reset values or 'q' to quit" + ]) -appEvent :: MyAppState () -> T.BrickEvent () e -> T.EventM () (T.Next (MyAppState ())) -appEvent p (T.VtyEvent e) = +appEvent :: T.BrickEvent () e -> T.EventM () (MyAppState ()) () +appEvent (T.VtyEvent e) = let valid = clamp (0.0 :: Float) 1.0 in case e of - V.EvKey (V.KChar 'x') [] -> M.continue $ p { x = valid $ x p + 0.05 } - V.EvKey (V.KChar 'y') [] -> M.continue $ p { y = valid $ y p + 0.03 } - V.EvKey (V.KChar 'z') [] -> M.continue $ p { z = valid $ z p + 0.02 } - V.EvKey (V.KChar 'q') [] -> M.halt p - _ -> M.continue p -appEvent p _ = M.continue p + V.EvKey (V.KChar 'x') [] -> x %= valid . (+ 0.05) + V.EvKey (V.KChar 'y') [] -> y %= valid . (+ 0.03) + V.EvKey (V.KChar 'z') [] -> z %= valid . (+ 0.02) + V.EvKey (V.KChar 't') [] -> showLabel %= not + V.EvKey (V.KChar 'r') [V.MCtrl] -> do + x .= 0 + y .= 0 + z .= 0 + V.EvKey (V.KChar 'r') [] -> T.put initialState + V.EvKey (V.KChar 'q') [] -> M.halt + _ -> return () +appEvent _ = return () initialState :: MyAppState () -initialState = MyAppState 0.25 0.18 0.63 +initialState = MyAppState 0.25 0.18 0.63 True theBaseAttr :: A.AttrName theBaseAttr = A.attrName "theBase" @@ -80,6 +111,18 @@ zDoneAttr = theBaseAttr <> A.attrName "Z:done" zToDoAttr = theBaseAttr <> A.attrName "Z:remaining" +cDoneAttr, cToDoAttr :: A.AttrName +cDoneAttr = A.attrName "C:done" +cToDoAttr = A.attrName "C:remaining" + +cDoneAttr1, cToDoAttr1 :: A.AttrName +cDoneAttr1 = A.attrName "C1:done" +cToDoAttr1 = A.attrName "C1:remaining" + +cDoneAttr2, cToDoAttr2 :: A.AttrName +cDoneAttr2 = A.attrName "C2:done" +cToDoAttr2 = A.attrName "C2:remaining" + theMap :: A.AttrMap theMap = A.attrMap V.defAttr [ (theBaseAttr, bg V.brightBlack) @@ -88,6 +131,12 @@ , (yDoneAttr, V.magenta `on` V.yellow) , (zDoneAttr, V.blue `on` V.green) , (zToDoAttr, V.blue `on` V.red) + , (cDoneAttr, fg V.blue) + , (cToDoAttr, fg V.blue) + , (cDoneAttr1, fg V.red) + , (cToDoAttr1, fg V.brightWhite) + , (cDoneAttr2, fg V.green) + , (cToDoAttr2, fg V.brightGreen) , (P.progressIncompleteAttr, fg V.yellow) ] @@ -96,7 +145,7 @@ M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor , M.appHandleEvent = appEvent - , M.appStartEvent = return + , M.appStartEvent = return () , M.appAttrMap = const theMap } diff --git a/programs/ReadmeDemo.hs b/programs/ReadmeDemo.hs --- a/programs/ReadmeDemo.hs +++ b/programs/ReadmeDemo.hs @@ -1,12 +1,13 @@ module Main where -import Brick -import Brick.Widgets.Center -import Brick.Widgets.Border -import Brick.Widgets.Border.Style +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")) diff --git a/programs/SuspendAndResumeDemo.hs b/programs/SuspendAndResumeDemo.hs --- a/programs/SuspendAndResumeDemo.hs +++ b/programs/SuspendAndResumeDemo.hs @@ -3,7 +3,7 @@ {-# LANGUAGE CPP #-} module Main where -import Lens.Micro ((.~), (^.), (&)) +import Lens.Micro ((^.)) import Lens.Micro.TH (makeLenses) import Control.Monad (void) #if !(MIN_VERSION_base(4,11,0)) @@ -13,7 +13,7 @@ import Brick.Main ( App(..), neverShowCursor, defaultMain - , suspendAndResume, halt, continue + , suspendAndResume, halt ) import Brick.AttrMap ( attrMap @@ -21,7 +21,6 @@ import Brick.Types ( Widget , EventM - , Next , BrickEvent(..) ) import Brick.Widgets.Core @@ -42,16 +41,16 @@ , str "(Press Esc to quit or Space to ask for input)" ] -appEvent :: St -> BrickEvent () e -> EventM () (Next St) -appEvent st (VtyEvent e) = +appEvent :: BrickEvent () e -> EventM () St () +appEvent (VtyEvent e) = case e of - V.EvKey V.KEsc [] -> halt st + V.EvKey V.KEsc [] -> halt V.EvKey (V.KChar ' ') [] -> suspendAndResume $ do putStrLn "Suspended. Please enter something and press enter to resume:" s <- getLine - return $ st & stExternalInput .~ s - _ -> continue st -appEvent st _ = continue st + return $ St { _stExternalInput = s } + _ -> return () +appEvent _ = return () initialState :: St initialState = @@ -63,7 +62,7 @@ App { appDraw = drawUI , appChooseCursor = neverShowCursor , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap V.defAttr [] } diff --git a/programs/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 --- a/programs/TextWrapDemo.hs +++ b/programs/TextWrapDemo.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE CPP #-} module Main where +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) +#endif import Brick import Text.Wrap (defaultWrapSettings, preserveIndentation) diff --git a/programs/ThemeDemo.hs b/programs/ThemeDemo.hs --- a/programs/ThemeDemo.hs +++ b/programs/ThemeDemo.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad (void) +import Control.Monad.State (put) import Graphics.Vty ( white, blue, green, yellow, black, magenta , Event(EvKey) @@ -18,7 +18,6 @@ ( Widget , BrickEvent(VtyEvent) , EventM - , Next ) import Brick.Widgets.Center ( hCenter @@ -32,7 +31,7 @@ , withDefAttr ) import Brick.Util (on, fg) -import Brick.AttrMap (AttrName) +import Brick.AttrMap (AttrName, attrName) ui :: Widget n ui = @@ -44,7 +43,7 @@ ] keybindingAttr :: AttrName -keybindingAttr = "keybinding" +keybindingAttr = attrName "keybinding" theme1 :: Theme theme1 = @@ -58,28 +57,28 @@ [ (keybindingAttr, fg yellow) ] -appEvent :: Int -> BrickEvent () e -> EventM () (Next Int) -appEvent _ (VtyEvent (EvKey (KChar '1') [])) = continue 1 -appEvent _ (VtyEvent (EvKey (KChar '2') [])) = continue 2 -appEvent s (VtyEvent (EvKey (KChar 'q') [])) = halt s -appEvent s (VtyEvent (EvKey KEsc [])) = halt s -appEvent s _ = continue s +appEvent :: BrickEvent () e -> EventM () Int () +appEvent (VtyEvent (EvKey (KChar '1') [])) = put 1 +appEvent (VtyEvent (EvKey (KChar '2') [])) = put 2 +appEvent (VtyEvent (EvKey (KChar 'q') [])) = halt +appEvent (VtyEvent (EvKey KEsc [])) = halt +appEvent _ = return () app :: App Int e () app = App { appDraw = const [ui] , appHandleEvent = appEvent - , appStartEvent = return + , appStartEvent = return () , appAttrMap = \s -> -- Note that in practice this is not ideal: we don't want - -- to build an attribute from a theme every time this is + -- 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. - if s == 1 - then themeToAttrMap theme1 - else themeToAttrMap theme2 + themeToAttrMap $ if s == 1 + then theme1 + else theme2 , appChooseCursor = neverShowCursor } diff --git a/programs/ViewportScrollDemo.hs b/programs/ViewportScrollDemo.hs --- a/programs/ViewportScrollDemo.hs +++ b/programs/ViewportScrollDemo.hs @@ -1,12 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Control.Monad (void) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) +#endif import qualified Graphics.Vty as V import qualified Brick.Types as T @@ -60,22 +59,22 @@ vp3Scroll :: M.ViewportScroll Name vp3Scroll = M.viewportScroll VP3 -appEvent :: () -> T.BrickEvent Name e -> T.EventM Name (T.Next ()) -appEvent _ (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy vp3Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy vp3Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = M.hScrollBy vp3Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = M.hScrollBy vp3Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp1Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp1Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp2Scroll 1 >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp2Scroll (-1) >> M.continue () -appEvent _ (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt () -appEvent _ _ = M.continue () +appEvent :: T.BrickEvent Name e -> T.EventM Name () () +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.vScrollBy vp3Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.vScrollBy vp3Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = M.hScrollBy vp3Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = M.hScrollBy vp3Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = M.vScrollBy vp1Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = M.vScrollBy vp1Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = M.hScrollBy vp2Scroll 1 +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = M.hScrollBy vp2Scroll (-1) +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () app :: M.App () e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const $ attrMap V.defAttr [] , M.appChooseCursor = M.neverShowCursor diff --git a/programs/ViewportScrollbarsDemo.hs b/programs/ViewportScrollbarsDemo.hs 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,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Main where @@ -6,6 +5,7 @@ import Control.Monad (void) import Lens.Micro import Lens.Micro.TH +import Lens.Micro.Mtl #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif @@ -15,7 +15,7 @@ import qualified Brick.Main as M import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B -import Brick.AttrMap (AttrMap, AttrName, attrMap) +import Brick.AttrMap (AttrMap, AttrName, attrMap, attrName) import Brick.Util (on) import Brick.Types ( Widget @@ -55,7 +55,7 @@ vp3Size = (25, 25) selectedAttr :: AttrName -selectedAttr = "selected" +selectedAttr = attrName "selected" drawUi :: St -> [Widget Name] drawUi st = [ui] @@ -102,17 +102,17 @@ vp3Scroll :: M.ViewportScroll Name vp3Scroll = M.viewportScroll VP3 -appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St) -appEvent st (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = M.continue $ st & vp3Index._1 %~ min (vp3Size^._1) . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = M.continue $ st & vp3Index._1 %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = M.continue $ st & vp3Index._2 %~ min (vp3Size^._1) . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = M.continue $ st & vp3Index._2 %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KDown [])) = M.continue $ st & vp1Index %~ min vp1Size . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KUp [])) = M.continue $ st & vp1Index %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KRight [])) = M.continue $ st & vp2Index %~ min vp2Size . (+ 1) -appEvent st (T.VtyEvent (V.EvKey V.KLeft [])) = M.continue $ st & vp2Index %~ max 1 . subtract 1 -appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st -appEvent st _ = M.continue st +appEvent :: T.BrickEvent Name e -> T.EventM Name St () +appEvent (T.VtyEvent (V.EvKey V.KDown [V.MCtrl])) = vp3Index._1 %= min (vp3Size^._1) . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [V.MCtrl])) = vp3Index._1 %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KRight [V.MCtrl])) = vp3Index._2 %= min (vp3Size^._1) . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = vp3Index._2 %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KDown [])) = vp1Index %= min vp1Size . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KUp [])) = vp1Index %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KRight [])) = vp2Index %= min vp2Size . (+ 1) +appEvent (T.VtyEvent (V.EvKey V.KLeft [])) = vp2Index %= max 1 . subtract 1 +appEvent (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt +appEvent _ = return () theMap :: AttrMap theMap = attrMap V.defAttr @@ -122,7 +122,7 @@ app :: M.App St e Name app = M.App { M.appDraw = drawUi - , M.appStartEvent = return + , M.appStartEvent = return () , M.appHandleEvent = appEvent , M.appAttrMap = const theMap , M.appChooseCursor = M.neverShowCursor diff --git a/programs/custom_keys.ini b/programs/custom_keys.ini new file mode 100644 --- /dev/null +++ b/programs/custom_keys.ini @@ -0,0 +1,4 @@ +[keybindings] +quit = x +increment = i +decrement = d diff --git a/src/Brick.hs b/src/Brick.hs --- a/src/Brick.hs +++ b/src/Brick.hs @@ -1,8 +1,11 @@ -- | This module is provided as a convenience to import the most --- important parts of the API all at once. Note that the Haddock --- documentation for this library is for /reference/ usage; if you --- are looking for an introduction or tutorial, see the README for links --- to plenty of material! +-- 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 @@ -2,9 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} -- | This module provides types and functions for managing an attribute -- map which maps attribute names ('AttrName') to attributes ('Attr'). --- This module is designed to be used with the 'OverloadedStrings' --- language extension to permit easy construction of 'AttrName' values --- and you should also use 'mappend' ('<>') to combine names. -- -- Attribute maps work by mapping hierarchical attribute names to -- attributes and inheriting parent names' attributes when child names @@ -17,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 @@ -30,6 +27,7 @@ -- * Construction , attrMap , forceAttrMap + , forceAttrMapAllowStyle , attrName -- * Inspection , attrNameComponents @@ -45,21 +43,16 @@ ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -import Data.Monoid -#endif - import qualified Data.Semigroup as Sem import Control.DeepSeq +import Data.Bits ((.|.)) import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.List (inits) -import Data.String (IsString(..)) 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. Hierarchy in an attribute name is used to @@ -69,9 +62,9 @@ -- example: -- -- @ --- "window" <> "border" --- "window" <> "title" --- "header" <> "clock" <> "seconds" +-- attrName "window" <> attrName "border" +-- attrName "window" <> attrName "title" +-- attrName "header" <> attrName "clock" <> attrName "seconds" -- @ data AttrName = AttrName [String] deriving (Show, Read, Eq, Ord, Generic, NFData) @@ -83,12 +76,10 @@ mempty = AttrName [] mappend = (Sem.<>) -instance IsString AttrName where - fromString = AttrName . (:[]) - -- | An attribute map which maps 'AttrName' values to 'Attr' values. data AttrMap = AttrMap Attr (M.Map AttrName Attr) | ForceAttr Attr + | ForceAttrAllowStyle Attr AttrMap deriving (Show, Generic, NFData) -- | Create an attribute name from a string. @@ -110,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 @@ -133,46 +129,60 @@ -- @ 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. 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 u1) (Attr s2 f2 b2 u2) = - Attr (s1 `combineMDs` s2) + Attr (s1 `combineStyles` s2) (f1 `combineMDs` f2) (b1 `combineMDs` b2) (u1 `combineMDs` u2) @@ -182,10 +192,17 @@ 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 diff --git a/src/Brick/BChan.hs b/src/Brick/BChan.hs --- a/src/Brick/BChan.hs +++ b/src/Brick/BChan.hs @@ -2,36 +2,43 @@ ( BChan , newBChan , writeBChan + , writeBChanNonBlocking , readBChan , readBChan2 ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif - 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@. +-- | 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. +-- | 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 --- |Reads the next value from the @BChan@; blocks if necessary. +-- | 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. +-- | 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 --- a/src/Brick/BorderMap.hs +++ b/src/Brick/BorderMap.hs @@ -1,13 +1,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} module Brick.BorderMap ( BorderMap , Edges(..) , eTopL, eBottomL, eRightL, eLeftL - , empty, emptyCoordinates, singleton + , empty, clear, emptyCoordinates, singleton , insertH, insertV, insert , unsafeUnion , coordinates, bounds @@ -18,7 +17,9 @@ ) where import Brick.Types.Common (Edges(..), Location(..), eTopL, eBottomL, eRightL, eLeftL, origin) +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative (liftA2) +#endif import Data.IMap (IMap, Run(Run)) import GHC.Generics import Control.DeepSeq @@ -54,14 +55,23 @@ emptyCoordinates :: Edges Int -> BorderMap a emptyCoordinates cs = BorderMap { _coordinates = cs, _values = pure IM.empty } --- | An empty 'BorderMap' that only tracks the point (0,0). +-- | 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 (pure 0) +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 $ empty +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 @@ -165,8 +175,8 @@ } where bounds' = neighbors coordinates' - values' = pure gc - <*> _coordinates m + values' = gc + <$> _coordinates m <*> coordinates' <*> bounds' <*> _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,7 +1,5 @@ -- | This module provides a type and functions for handling focus rings -- of values. --- --- This interface is experimental. module Brick.Focus ( FocusRing , focusRing @@ -9,6 +7,8 @@ , focusPrev , focusGetCurrent , focusSetCurrent + , focusRingLength + , focusRingToList , focusRingCursor , withFocusRing , focusRingModify @@ -16,7 +16,7 @@ where import Lens.Micro ((^.)) -import Data.Maybe (listToMaybe) +import Data.List (find) import qualified Data.CircularList as C import Brick.Types @@ -25,6 +25,7 @@ -- | A focus ring containing a sequence of resource names to focus and a -- currently-focused name. newtype FocusRing n = FocusRing (C.CList n) + deriving (Show) -- | Construct a focus ring from the list of resource names. focusRing :: [n] -> FocusRing n @@ -58,13 +59,13 @@ -> (Bool -> a -> b) -- ^ A function that takes a value and its focus state. -> a - -- ^ The wiget state value that we need to check for focus. + -- ^ 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 emtpy, return 'Nothing'. +-- is empty, return 'Nothing'. focusGetCurrent :: FocusRing n -> Maybe n focusGetCurrent (FocusRing l) = C.focus l @@ -76,6 +77,18 @@ 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. @@ -95,8 +108,5 @@ -> Maybe (CursorLocation n) -- ^ The cursor position, if any, that matches the -- resource name currently focused by the 'FocusRing'. -focusRingCursor getRing st ls = - listToMaybe $ filter isCurrent ls - where - isCurrent cl = cl^.cursorLocationNameL == - (focusGetCurrent $ getRing st) +focusRingCursor getRing st = find $ \cl -> + cl^.cursorLocationNameL == focusGetCurrent (getRing st) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -3,9 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} --- | NOTE: This API is experimental and will probably change. Please try --- it out! Feedback is very much appreciated, and your patience in the --- face of breaking API changes is also appreciated! +{-# 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 @@ -19,10 +22,6 @@ -- user when a form field's value is invalid, and stores valid inputs in -- your data type when possible. -- --- This module provides the API to create forms, populate them with some --- basic input field types, render forms, handle form events, and create --- custom input field types. --- -- 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 @@ -32,6 +31,11 @@ -- '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 @@ -45,6 +49,7 @@ Form , FormFieldState(..) , FormField(..) + , FormFieldVisibilityMode(..) -- * Creating and using forms , newForm @@ -60,10 +65,13 @@ , setFormConcat , setFieldConcat , setFormFocus + , updateFormState + , setFieldVisibilityMode -- * Simple form field constructors , editTextField , editShowableField + , editShowableFieldWithValidate , editPasswordField , radioField , checkboxField @@ -85,13 +93,12 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif -import Data.Maybe (isJust, isNothing) +import Data.Maybe (fromJust, isJust, isNothing) import Data.List (elemIndex) import Data.Vector (Vector) import Brick import Brick.Focus -import Brick.Widgets.Core (showCursor) import Brick.Widgets.Edit import Brick.Widgets.List import qualified Data.Text.Zipper as Z @@ -100,6 +107,7 @@ import Text.Read (readMaybe) import Lens.Micro +import Lens.Micro.Mtl -- | A form field. This represents an interactive input field in the -- form. Its user input is validated and thus converted into a type of @@ -113,34 +121,47 @@ -- * @e@ - your application's event type -- * @n@ - your application's resource name type data FormField a b e n = - FormField { formFieldName :: n + FormField { formFieldName :: n -- ^ The name identifying this form field. - , formFieldValidate :: b -> Maybe a + , 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 s - -- aan integer and return 'Maybe' 'Int'. This is for pure - -- avalue validation; if additional validation is required - -- a(e.g. via 'IO'), use this field's state value in an - -- aexternal validation routine and use 'setFieldValid' to - -- afeed the result back into the form. + -- 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 + , 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 -> b -> EventM n b - -- ^ An event handler for this field. This receives the - -- event and the field state and returns a new field - -- state. + , formFieldHandleEvent :: BrickEvent n e -> EventM n b () + -- ^ An event handler for this field. } +-- | 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 @@ -166,11 +187,14 @@ -- the field collection. Note that this type is -- existential. All form fields in the collection -- must validate to this type. - , formFieldLens :: Lens' s a + , formFieldLens :: Lens' s a -- ^ A lens to extract and store a -- successfully-validated form input back into -- your form state. - , formFields :: [FormField a b e n] + , 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 @@ -182,10 +206,14 @@ , 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. +-- underlying state that you choose. This value must be stored in the +-- Brick application's state. -- -- Type variables are as follows: -- @@ -195,10 +223,10 @@ -- * @n@ - your application's resource name type data Form s e n = Form { formFieldStates :: [FormFieldState s e n] - , formFocus :: FocusRing n + , formFocus :: FocusRing n -- ^ The focus ring for the form, indicating which form field -- has input focus. - , formState :: s + , 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 @@ -209,6 +237,8 @@ -- ^ Concatenation function for this form's field renderings. } +suffixLenses ''Form + -- | Compose a new rendering augmentation function with the one in the -- form field collection. For example, we might put a label on the left -- side of a form field: @@ -227,6 +257,25 @@ 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 } @@ -252,13 +301,13 @@ newForm mkEs s = let es = mkEs <*> pure s in Form { formFieldStates = es - , formFocus = focusRing $ concat $ formFieldNames <$> es + , formFocus = focusRing $ concatMap formFieldNames es , formState = s , formConcatAll = vBox } formFieldNames :: FormFieldState s e n -> [n] -formFieldNames (FormFieldState _ _ fields _ _) = formFieldName <$> fields +formFieldNames (FormFieldState _ _ _ fields _ _ _) = formFieldName <$> fields -- | A form field for manipulating a boolean value. This represents -- 'True' as @[X] label@ and 'False' as @[ ] label@. @@ -302,24 +351,27 @@ checkboxCustomField lb check rb stLens name label initialState = let initVal = initialState ^. stLens - handleEvent (MouseDown n _ _ _) s | n == name = return $ not s - handleEvent (VtyEvent (EvKey (KChar ' ') [])) s = return $ not s - handleEvent _ s = return s + handleEvent (MouseDown n _ _ _) | n == name = modify not + handleEvent (VtyEvent (EvKey (KChar ' ') [])) = modify not + handleEvent _ = return () - in FormFieldState { formFieldState = initVal - , formFields = [ FormField name Just True - (renderCheckbox lb check rb label name) - handleEvent - ] - , formFieldLens = stLens + 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 + , formFieldConcat = vBox + , formFieldVisibilityMode = ShowFocusedFieldOnly } -renderCheckbox :: Char -> Char -> Char -> T.Text -> n -> Bool -> Bool -> Widget n +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 showCursor n (Location (1,0)) 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 " ") <> @@ -328,6 +380,9 @@ -- | A form field for selecting a single choice from a set of possible -- choices in a scrollable list. This uses a 'List' internally. -- +-- This field's attributes are governed by those exported from +-- 'Brick.Widgets.List'. +-- -- This field responds to the same input events that a 'List' does. listField :: forall s e n a . (Ord n, Show n, Eq a) => (s -> Vector a) @@ -357,18 +412,24 @@ Just e -> listMoveToElement e l setList s l = s & stLens .~ (snd <$> listSelectedElement l) - handleEvent (VtyEvent e) s = handleListEvent e s - handleEvent _ s = return s + handleEvent (VtyEvent e) = handleListEvent e + handleEvent _ = return () - in FormFieldState { formFieldState = initVal - , formFields = [ FormField name Just True - (renderList renderItem) - handleEvent - ] - , formFieldLens = customStLens + 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 + , 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. -- @@ -393,8 +454,11 @@ -- 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)] @@ -412,12 +476,12 @@ [(val, _, _)] -> Just val _ -> Nothing - handleEvent _ (MouseDown n _ _ _) s = + handleEvent _ (MouseDown n _ _ _) = case lookupOptionValue n of - Nothing -> return s - Just v -> return v - handleEvent new (VtyEvent (EvKey (KChar ' ') [])) _ = return new - handleEvent _ _ s = return s + Nothing -> return () + Just v -> put v + handleEvent new (VtyEvent (EvKey (KChar ' ') [])) = put new + handleEvent _ _ = return () optionFields = mkOptionField <$> options mkOptionField (val, name, label) = @@ -427,31 +491,37 @@ (renderRadio lb check rb val name label) (handleEvent val) - in FormFieldState { formFieldState = initVal - , formFields = optionFields - , formFieldLens = stLens + in FormFieldState { formFieldState = initVal + , formFields = optionFields + , formFieldLens = stLens + , formFieldUpdate = \val _ -> val , formFieldRenderHelper = id - , formFieldConcat = vBox + , formFieldConcat = vBox + , formFieldVisibilityMode = ShowFocusedFieldOnly } -renderRadio :: (Eq a) => Char -> Char -> Char -> a -> n -> T.Text -> Bool -> a -> Widget n +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 showCursor name (Location (1,0)) else id + csr = if foc then putCursor name (Location (1,0)) else id in clickable name $ addAttr $ csr $ - hBox [ txt $ T.singleton lb - , txt $ if isSet then T.singleton check else " " - , txt $ T.singleton rb <> " " <> label - ] + txt $ T.concat + [ T.singleton lb + , if isSet then T.singleton check else " " + , T.singleton rb <> " " <> label + ] -- | A form field for using an editor to edit the text representation of -- a value. The other editing fields in this module are special cases of -- 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) @@ -466,7 +536,7 @@ -- the editor's initial contents. The resulting text may -- contain newlines. -> ([T.Text] -> Maybe a) - -- ^ The validation function that converts the editors + -- ^ 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 @@ -486,19 +556,23 @@ then id else Z.moveCursor pos initialText = ini $ initialState ^. stLens - handleEvent (VtyEvent e) ed = handleEditorEvent e ed - handleEvent _ ed = return ed in FormFieldState { formFieldState = initVal - , formFields = [ FormField n - (val . getEditContents) - True - (\b e -> wrapEditor $ renderEditor renderText b e) - handleEvent - ] - , formFieldLens = stLens + , 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' @@ -507,6 +581,9 @@ -- useful in cases where the user-facing representation of a value -- matches the 'Show' representation exactly, such as with 'Int'. -- +-- This field's attributes are governed by those exported from +-- 'Brick.Widgets.Edit'. +-- -- This field responds to all events handled by 'editor', including -- mouse events. editShowableField :: (Ord n, Show n, Read a, Show a) @@ -518,8 +595,39 @@ -- ^ 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 = readMaybe . T.unpack . T.intercalate "\n" + 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 @@ -527,6 +635,9 @@ -- | A form field using an editor to edit a text value. Since the value -- is free-form text, it is always valid. -- +-- This field's attributes are governed by those exported from +-- 'Brick.Widgets.Edit'. +-- -- This field responds to all events handled by 'editor', including -- mouse events. editTextField :: (Ord n, Show n) @@ -549,6 +660,9 @@ -- value represented as a password. The value is always considered valid -- and is always represented with one asterisk per password character. -- +-- This field's attributes are governed by those exported from +-- 'Brick.Widgets.Edit'. +-- -- This field responds to all events handled by 'editor', including -- mouse events. editPasswordField :: (Ord n, Show n) @@ -571,15 +685,22 @@ -- | The namespace for the other form attributes. formAttr :: AttrName -formAttr = "brickForm" +formAttr = attrName "brickForm" --- | The attribute for form input fields with invalid values. +-- | The attribute for form input fields with invalid values. Note that +-- this attribute will affect any field considered invalid and will take +-- priority over any attributes that the field uses to render itself. invalidFormInputAttr :: AttrName -invalidFormInputAttr = formAttr <> "invalidInput" +invalidFormInputAttr = formAttr <> attrName "invalidInput" --- | The attribute for form input fields that have the focus. +-- | The attribute for form input fields that have the focus. Note that +-- this attribute only affects fields that do not already use their own +-- attributes when rendering, such as editor- and list-based fields. +-- Those need to be styled by setting the appropriate attributes; see +-- the documentation for field constructors to find out which attributes +-- need to be configured. focusedFormInputAttr :: AttrName -focusedFormInputAttr = formAttr <> "focusedInput" +focusedFormInputAttr = formAttr <> attrName "focusedInput" -- | Returns whether all form fields in the form currently have valid -- values according to the fields' validation functions. This is useful @@ -593,8 +714,53 @@ -- force the user to repair invalid inputs before moving on from a form -- editing session. invalidFields :: Form s e n -> [n] -invalidFields f = concat $ getInvalidFields <$> formFieldStates f +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 @@ -611,21 +777,21 @@ let go1 [] = [] go1 (s:ss) = let s' = case s of - FormFieldState st l fs rh concatAll -> + FormFieldState st l upd fs rh concatAll visMode -> let go2 [] = [] go2 (f@(FormField fn val _ r h):ff) | n == fn = FormField fn val v r h : ff | otherwise = f : go2 ff - in FormFieldState st l (go2 fs) rh concatAll + in FormFieldState st l upd (go2 fs) rh concatAll visMode in s' : go1 ss in form { formFieldStates = go1 (formFieldStates form) } getInvalidFields :: FormFieldState s e n -> [n] -getInvalidFields (FormFieldState st _ fs _ _) = +getInvalidFields (FormFieldState st _ _ fs _ _ _) = let gather (FormField n validate extValid _ _) = - if (not extValid || (isNothing $ validate st)) then [n] else [] - in concat $ gather <$> fs + if not extValid || isNothing (validate st) then [n] else [] + in concatMap gather fs -- | Render a form. -- @@ -639,7 +805,9 @@ -- 'invalidFormInputAttr' attribute. -- -- Finally, all of the resulting field renderings are concatenated with --- the form's concatenation function (see 'setFormConcat'). +-- the form's concatenation function (see 'setFormConcat'). A visibility +-- request is also issued for the currently-focused form field in case +-- the form is rendered within a viewport. renderForm :: (Eq n) => Form s e n -> Widget n renderForm (Form es fr _ concatAll) = concatAll $ renderFormFieldState fr <$> es @@ -652,18 +820,27 @@ => FocusRing n -> FormFieldState s e n -> Widget n -renderFormFieldState fr (FormFieldState st _ fields helper concatFields) = - let renderFields [] = [] +renderFormFieldState fr (FormFieldState st _ _ fields helper concatFields visMode) = + let curFocus = focusGetCurrent fr + foc = case curFocus of + Nothing -> False + Just n -> n `elem` fieldNames + maybeVisible = if foc && visMode == ShowCompositeField then visible else id + renderFields [] = [] renderFields ((FormField n validate extValid renderField _):fs) = let maybeInvalid = if (isJust $ validate st) && extValid then id else forceAttr invalidFormInputAttr - foc = Just n == focusGetCurrent fr - in maybeInvalid (renderField foc st) : renderFields fs - in helper $ concatFields $ renderFields fields + fieldFoc = Just n == curFocus + maybeFieldVisible = if fieldFoc && visMode == ShowFocusedFieldOnly then visible else id + in (n, maybeFieldVisible $ maybeInvalid $ renderField fieldFoc st) : renderFields fs + (fieldNames, renderedFields) = unzip $ renderFields fields + maybeHelperVisible = + if foc && visMode == ShowAugmentedField then visible else id + in maybeHelperVisible $ helper $ maybeVisible $ concatFields renderedFields --- | Dispatch an event to the appropriate form field and return a new --- form. This handles the following events in this order: +-- | Dispatch an event to the currently focused form field. This handles +-- the following events in this order: -- -- * On @Tab@ keypresses, this changes the focus to the next field in -- the form. @@ -688,44 +865,31 @@ -- lens. The external validation flag is ignored during this step to -- ensure that external validators have a chance to get the intermediate -- validated value. -handleFormEvent :: (Eq n) => BrickEvent n e -> Form s e n -> EventM n (Form s e n) -handleFormEvent (VtyEvent (EvKey (KChar '\t') [])) f = - return $ f { formFocus = focusNext $ formFocus f } -handleFormEvent (VtyEvent (EvKey KBackTab [])) f = - return $ f { formFocus = focusPrev $ formFocus f } -handleFormEvent e@(MouseDown n _ _ _) f = - handleFormFieldEvent n e $ f { formFocus = focusSetCurrent n (formFocus f) } -handleFormEvent e@(MouseUp n _ _) f = - handleFormFieldEvent n e $ f { formFocus = focusSetCurrent n (formFocus f) } -handleFormEvent e@(VtyEvent (EvKey KUp [])) f = - case focusGetCurrent (formFocus f) of - Nothing -> return f - Just n -> - case getFocusGrouping f n of - Nothing -> forwardToCurrent e f - Just grp -> return $ f { formFocus = focusSetCurrent (entryBefore grp n) (formFocus f) } -handleFormEvent e@(VtyEvent (EvKey KDown [])) f = - case focusGetCurrent (formFocus f) of - Nothing -> return f - Just n -> - case getFocusGrouping f n of - Nothing -> forwardToCurrent e f - Just grp -> return $ f { formFocus = focusSetCurrent (entryAfter grp n) (formFocus f) } -handleFormEvent e@(VtyEvent (EvKey KLeft [])) f = - case focusGetCurrent (formFocus f) of - Nothing -> return f - Just n -> - case getFocusGrouping f n of - Nothing -> forwardToCurrent e f - Just grp -> return $ f { formFocus = focusSetCurrent (entryBefore grp n) (formFocus f) } -handleFormEvent e@(VtyEvent (EvKey KRight [])) f = - case focusGetCurrent (formFocus f) of - Nothing -> return f - Just n -> - case getFocusGrouping f n of - Nothing -> forwardToCurrent e f - Just grp -> return $ f { formFocus = focusSetCurrent (entryAfter grp n) (formFocus f) } -handleFormEvent e f = forwardToCurrent e f +handleFormEvent :: (Eq n) => BrickEvent n e -> EventM n (Form s e n) () +handleFormEvent (VtyEvent (EvKey (KChar '\t') [])) = + formFocusL %= focusNext +handleFormEvent (VtyEvent (EvKey KBackTab [])) = + formFocusL %= focusPrev +handleFormEvent e@(MouseDown n _ _ _) = do + formFocusL %= focusSetCurrent n + handleFormFieldEvent e n +handleFormEvent e@(MouseUp n _ _) = do + formFocusL %= focusSetCurrent n + handleFormFieldEvent e n +handleFormEvent e@(VtyEvent (EvKey KUp [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryBefore grp n) +handleFormEvent e@(VtyEvent (EvKey KDown [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryAfter grp n) +handleFormEvent e@(VtyEvent (EvKey KLeft [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryBefore grp n) +handleFormEvent e@(VtyEvent (EvKey KRight [])) = + withFocusAndGrouping e $ \n grp -> + formFocusL %= focusSetCurrent (entryAfter grp n) +handleFormEvent e = + forwardToCurrent e getFocusGrouping :: (Eq n) => Form s e n -> n -> Maybe [n] getFocusGrouping f n = findGroup (formFieldStates f) @@ -739,34 +903,52 @@ entryAfter :: (Eq a) => [a] -> a -> a entryAfter as a = - let Just i = elemIndex a as + 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 Just i = elemIndex a as + let i = fromJust $ elemIndex a as i' = if i == 0 then length as - 1 else i - 1 in as !! i' -forwardToCurrent :: (Eq n) => BrickEvent n e -> Form s e n -> EventM n (Form s e n) -forwardToCurrent e f = - case focusGetCurrent (formFocus f) of - Nothing -> return f - Just n -> handleFormFieldEvent n e f +withFocusAndGrouping :: (Eq n) + => BrickEvent n e + -> (n -> [n] -> EventM n (Form s e n) ()) + -> EventM n (Form s e n) () +withFocusAndGrouping e act = do + foc <- gets formFocus + case focusGetCurrent foc of + Nothing -> return () + Just n -> do + f <- get + case getFocusGrouping f n of + Nothing -> forwardToCurrent e + Just grp -> act n grp -handleFormFieldEvent :: (Eq n) => n -> BrickEvent n e -> Form s e n -> EventM n (Form s e n) -handleFormFieldEvent n ev f = findFieldState [] (formFieldStates f) - where - findFieldState _ [] = return f +withFocus :: (n -> EventM n (Form s e n) ()) -> EventM n (Form s e n) () +withFocus act = do + foc <- gets formFocus + case focusGetCurrent foc of + Nothing -> return () + Just n -> act n + +forwardToCurrent :: (Eq n) => BrickEvent n e -> EventM n (Form s e n) () +forwardToCurrent = + withFocus . handleFormFieldEvent + +handleFormFieldEvent :: (Eq n) => BrickEvent n e -> n -> EventM n (Form s e n) () +handleFormFieldEvent ev n = do + let findFieldState _ [] = return () findFieldState prev (e:es) = case e of - FormFieldState st stLens fields helper concatAll -> do + 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 <- handleFunc ev st + (nextSt, ()) <- nestEventM st (handleFunc ev) -- If the new state validates, go ahead and update -- the form state with it. case validate nextSt of @@ -777,10 +959,12 @@ result <- findField fields case result of Nothing -> findFieldState (prev <> [e]) es - Just (newSt, maybeSt) -> - let newFieldState = FormFieldState newSt stLens fields helper concatAll - in return $ f { formFieldStates = prev <> [newFieldState] <> es - , formState = case maybeSt of - Nothing -> formState f - Just s -> formState f & stLens .~ s - } + 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,17 +1,21 @@ {-# 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 @@ -45,21 +49,18 @@ , renderFinal , getRenderState , resetRenderState + , renderWidget ) where import qualified Control.Exception as E import Lens.Micro ((^.), (&), (.~), (%~), _1, _2) -import Control.Monad (forever) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Reader import Control.Concurrent (forkIO, killThread) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -import Data.Monoid (mempty) -#endif 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 @@ -73,27 +74,31 @@ , displayBounds , shutdown , nextEvent - , mkVty - , defaultConfig + , restoreInputState + , inputIface ) +import Graphics.Vty.CrossPlatform (mkVty) +import Graphics.Vty.Config (defaultConfig) import Graphics.Vty.Attributes (defAttr) import Brick.BChan (BChan, newBChan, readBChan, readBChan2, writeBChan) -import Brick.Types (Widget, EventM(..)) +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', 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 is the type of application --- state to be provided by you and iteratively modified by event --- handlers. The resource name type is the type of names you can assign --- to rendering resources such as viewports and cursor locations. +-- 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 @@ -106,12 +111,10 @@ -- is that many widgets may request a cursor placement but your -- application state is what you probably want to use to decide -- which one wins. - , appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s) - -- ^ 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 n 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. @@ -120,8 +123,8 @@ } -- | The default main entry point which takes an application and an --- initial state and returns the final state returned by a 'halt' --- operation. +-- initial state and returns the final state from 'EventM' once the +-- program exits. defaultMain :: (Ord n) => App s e n -- ^ The application. @@ -129,9 +132,9 @@ -- ^ The initial application state. -> IO s defaultMain app st = do - let builder = mkVty defaultConfig - initialVty <- builder - customMain initialVty builder Nothing app st + (s, vty) <- customMainWithDefaultVty Nothing app st + shutdown vty + return s -- | A simple main entry point which takes a widget and renders it. This -- event loop terminates when the user presses any key, but terminal @@ -154,7 +157,7 @@ simpleApp w = App { appDraw = const [w] , appHandleEvent = resizeOrQuit - , appStartEvent = return + , appStartEvent = return () , appAttrMap = const $ attrMap defAttr [] , appChooseCursor = neverShowCursor } @@ -164,44 +167,47 @@ -- a halt. This is a convenience function useful as an 'appHandleEvent' -- value for simple applications using the 'Event' type that do not need -- to get more sophisticated user input. -resizeOrQuit :: s -> BrickEvent n e -> EventM n (Next s) -resizeOrQuit s (VtyEvent (EvResize _ _)) = continue s -resizeOrQuit s _ = halt s - -data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a) - | InternalHalt a +resizeOrQuit :: BrickEvent n e -> EventM n s () +resizeOrQuit (VtyEvent (EvResize _ _)) = return () +resizeOrQuit _ = halt readBrickEvent :: BChan (BrickEvent n e) -> BChan e -> IO (BrickEvent n e) readBrickEvent brickChan userChan = either id AppEvent <$> readBChan2 brickChan userChan runWithVty :: (Ord n) - => Vty + => VtyContext -> BChan (BrickEvent n e) -> Maybe (BChan e) -> App s e n -> RenderState n -> s - -> IO (InternalNext n s) -runWithVty vty brickChan mUserChan app initialRS initialSt = do - pid <- forkIO $ supplyVtyEvents vty brickChan + -> IO (s, VtyContext) +runWithVty vtyCtx brickChan mUserChan app initialRS initialSt = do let readEvent = case mUserChan of Nothing -> readBChan brickChan Just uc -> readBrickEvent brickChan uc - runInner rs st = do - (result, newRS) <- runVty vty readEvent app st (resetRenderState rs) + 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 - 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 + Halt -> + return (nextSt, newCtx) + Continue -> + runInner newCtx newRS newExtents True nextSt + ContinueWithoutRedraw -> + runInner newCtx newRS newExtents False nextSt + runInner vtyCtx initialRS mempty True initialSt + -- | The custom event loop entry point to use when the simpler ones -- don't permit enough control. Returns the final application state -- after the application halts. +-- +-- 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. @@ -221,10 +227,38 @@ -- ^ The initial application state. -> IO s customMain initialVty buildVty mUserChan app initialAppState = do + let restoreInitialState = restoreInputState $ inputIface initialVty + (s, vty) <- customMainWithVty initialVty buildVty mUserChan app initialAppState + `E.catch` (\(e::E.SomeException) -> restoreInitialState >> E.throw e) + shutdown vty + restoreInitialState return s +-- | Like 'customMainWithVty', except that Vty is initialized with the +-- default configuration. +-- +-- The returned 'Vty' handle still has control of the terminal. The +-- caller is responsible for calling 'shutdown' to restore the terminal +-- state. +customMainWithDefaultVty :: (Ord n) + => Maybe (BChan e) + -- ^ An event channel for sending custom + -- events to the event loop (you write to this + -- channel, the event loop reads from it). + -- Provide 'Nothing' if you don't plan on + -- sending custom events. + -> App s e n + -- ^ The application. + -> s + -- ^ The initial application state. + -> IO (s, Vty) +customMainWithDefaultVty mUserChan app initialAppState = do + let builder = mkVty defaultConfig + vty <- builder + customMainWithVty vty builder mUserChan app initialAppState + -- | Like 'customMain', except the last 'Vty' handle used by the -- application is returned without being shut down with 'shutdown'. This -- allows the caller to re-use the 'Vty' handle for something else, such @@ -248,41 +282,80 @@ -- ^ The initial application state. -> IO (s, Vty) customMainWithVty initialVty buildVty mUserChan app initialAppState = do - let run vty rs st brickChan = do - result <- runWithVty vty brickChan mUserChan app rs st - `E.catch` (\(e::E.SomeException) -> shutdown vty >> E.throw e) - case result of - InternalHalt s -> return (s, vty) - InternalSuspendAndResume newRS action -> do - shutdown vty - newAppState <- action - newVty <- buildVty - run newVty (newRS { renderCache = mempty }) newAppState brickChan + brickChan <- newBChan 20 + vtyCtx <- newVtyContext buildVty (Just initialVty) (writeBChan brickChan . VtyEvent) - let emptyES = ES [] mempty - emptyRS = RS M.empty mempty S.empty mempty mempty - eventRO = EventRO M.empty initialVty mempty emptyRS + 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 - (st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) eventRO) emptyES - let initialRS = RS M.empty (esScrollRequests eState) S.empty mempty [] - brickChan <- newBChan 20 - run initialVty initialRS st brickChan + (((), 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 + } -supplyVtyEvents :: Vty -> BChan (BrickEvent n e) -> IO () -supplyVtyEvents vty chan = - forever $ do - e <- nextEvent vty - writeBChan chan $ VtyEvent e + (s, ctx) <- runWithVty vtyCtx brickChan mUserChan app initialRS appState + `E.catch` (\(e::E.SomeException) -> shutdownVtyContext vtyCtx >> E.throw e) + -- Shut down the context's event thread but do NOT shut down Vty + -- itself because we want the handle to be live when we return it to + -- the caller. + shutdownVtyContextThread ctx + return (s, vtyContextHandle ctx) + +supplyVtyEvents :: Vty -> (Event -> IO ()) -> IO () +supplyVtyEvents vty putEvent = + forever $ putEvent =<< nextEvent vty + +newVtyContextFrom :: VtyContext -> IO VtyContext +newVtyContextFrom old = + newVtyContext (vtyContextBuilder old) Nothing (vtyContextPutEvent old) + +newVtyContext :: IO Vty -> Maybe Vty -> (Event -> IO ()) -> IO VtyContext +newVtyContext builder handle putEvent = do + vty <- case handle of + Just h -> return h + Nothing -> builder + tId <- forkIO $ supplyVtyEvents vty putEvent + return VtyContext { vtyContextHandle = vty + , vtyContextBuilder = builder + , vtyContextThread = tId + , vtyContextPutEvent = putEvent + } + +shutdownVtyContext :: VtyContext -> IO () +shutdownVtyContext ctx = do + shutdown $ vtyContextHandle ctx + shutdownVtyContextThread ctx + +shutdownVtyContextThread :: VtyContext -> IO () +shutdownVtyContextThread ctx = + killThread $ vtyContextThread ctx + runVty :: (Ord n) - => Vty + => VtyContext -> IO (BrickEvent n e) -> App s e n -> s -> RenderState n - -> IO (Next s, RenderState n) -runVty vty readEvent app appState rs = do - (firstRS, exts) <- renderApp vty app appState rs + -> [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 @@ -291,67 +364,73 @@ -- want the event handler to have access to accurate viewport -- information. VtyEvent (EvResize _ _) -> do - (rs', exts') <- renderApp vty app appState $ firstRS & observedNamesL .~ S.empty + (rs', exts') <- renderApp vtyCtx app appState $ firstRS & observedNamesL .~ S.empty return (e, rs', exts') VtyEvent (EvMouseDown c r button mods) -> do let matching = findClickedExtents_ (c, r) exts case matching of - (Extent n (Location (ec, er)) _ (Location (oC, oR)):_) -> + (Extent n (Location (ec, er)) _:_) -> -- If the clicked extent was registered as -- clickable, send a click event. Otherwise, just -- send the raw mouse event - case n `elem` firstRS^.clickableNamesL of - True -> do - let localCoords = Location (lc, lr) - lc = c - ec + oC - lr = r - er + oR + 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)) + -- 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) - False -> return (e, firstRS, exts) + 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)) _ (Location (oC, oR)):_) -> + (Extent n (Location (ec, er)) _:_) -> -- If the clicked extent was registered as -- clickable, send a click event. Otherwise, just -- send the raw mouse event - case n `elem` firstRS^.clickableNamesL of - True -> do - let localCoords = Location (lc, lr) - lc = c - ec + oC - lr = r - er + oR - -- 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) - False -> return (e, firstRS, exts) + 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 - eventRO = EventRO (viewportMap nextRS) vty nextExts nextRS + let emptyES = ES [] mempty mempty Continue vtyCtx + eventRO = EventRO (viewportMap nextRS) nextExts nextRS - (next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e')) - eventRO) emptyES - return (next, nextRS { rsScrollRequests = esScrollRequests eState - , renderCache = applyInvalidations (cacheInvalidateRequests eState) $ - renderCache 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 = @@ -366,51 +445,63 @@ -- 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 :: (Ord n) => n -> EventM n (Maybe Viewport) +-- 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) -- | Did the specified mouse coordinates (column, row) intersect the -- specified extent? clickedExtent :: (Int, Int) -> Extent n -> Bool -clickedExtent (c, r) (Extent _ (Location (lc, lr)) (w, h) _) = +clickedExtent (c, r) (Extent _ (Location (lc, lr)) (w, h)) = c >= lc && c < (lc + w) && r >= lr && r < (lr + h) -- | Given a resource name, get the most recent rendering extent for the -- name (if any). -lookupExtent :: (Eq n) => n -> EventM n (Maybe (Extent n)) -lookupExtent n = EventM $ asks (listToMaybe . filter f . latestExtents) +lookupExtent :: (Eq n) => n -> EventM n s (Maybe (Extent n)) +lookupExtent n = EventM $ asks (find f . latestExtents) where - f (Extent n' _ _ _) = n == n' + 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 [Extent n] +findClickedExtents :: (Int, Int) -> EventM n s [Extent n] findClickedExtents pos = EventM $ asks (findClickedExtents_ pos . latestExtents) findClickedExtents_ :: (Int, Int) -> [Extent n] -> [Extent n] findClickedExtents_ pos = reverse . filter (clickedExtent pos) -- | Get the Vty handle currently in use. -getVtyHandle :: EventM n Vty -getVtyHandle = EventM $ asks eventVtyHandle +getVtyHandle :: EventM n s Vty +getVtyHandle = vtyContextHandle <$> getVtyContext +setVtyContext :: VtyContext -> EventM n s () +setVtyContext ctx = + EventM $ lift $ lift $ modify $ \s -> s { vtyContext = ctx } + -- | Invalidate the rendering cache entry with the specified resource -- name. -invalidateCacheEntry :: (Ord n) => n -> EventM n () +invalidateCacheEntry :: (Ord n) => n -> EventM n s () invalidateCacheEntry n = EventM $ do - lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s }) + lift $ lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s }) -- | Invalidate the entire rendering cache. -invalidateCache :: (Ord n) => EventM n () +invalidateCache :: (Ord n) => EventM n s () invalidateCache = EventM $ do - lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s }) + lift $ lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s }) -getRenderState :: EventM n (RenderState n) +getRenderState :: EventM n s (RenderState n) getRenderState = EventM $ asks oldState resetRenderState :: RenderState n -> RenderState n @@ -418,9 +509,9 @@ s & observedNamesL .~ S.empty & clickableNamesL .~ mempty -renderApp :: Vty -> App s e n -> s -> RenderState n -> IO (RenderState n, [Extent n]) -renderApp vty app appState rs = do - sz <- displayBounds $ outputIface vty +renderApp :: (Ord n) => VtyContext -> App s e n -> s -> RenderState n -> IO (RenderState n, [Extent n]) +renderApp vtyCtx app appState rs = do + sz <- displayBounds $ outputIface $ vtyContextHandle vtyCtx let (newRS, pic, theCursor, exts) = renderFinal (appAttrMap app appState) (appDraw app appState) sz @@ -428,11 +519,14 @@ rs picWithCursor = case theCursor of Nothing -> pic { picCursor = NoCursor } - Just cloc -> pic { picCursor = AbsoluteCursor (cloc^.locationColumnL) - (cloc^.locationRowL) + 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, exts) @@ -455,7 +549,7 @@ showCursorNamed :: (Eq n) => n -> [CursorLocation n] -> Maybe (CursorLocation n) showCursorNamed name locs = let matches l = l^.cursorLocationNameL == Just name - in listToMaybe $ filter matches locs + in find matches locs -- | A viewport scrolling handle for managing the scroll state of -- viewports. @@ -463,38 +557,38 @@ ViewportScroll { viewportName :: n -- ^ The name of the viewport to be controlled by -- this scrolling handle. - , hScrollPage :: Direction -> EventM n () + , hScrollPage :: forall s. Direction -> EventM n s () -- ^ Scroll the viewport horizontally by one page in -- the specified direction. - , hScrollBy :: Int -> EventM n () + , hScrollBy :: forall s. Int -> EventM n s () -- ^ Scroll the viewport horizontally by the -- specified number of rows or columns depending on -- the orientation of the viewport. - , hScrollToBeginning :: EventM n () + , hScrollToBeginning :: forall s. EventM n s () -- ^ Scroll horizontally to the beginning of the -- viewport. - , hScrollToEnd :: EventM n () + , hScrollToEnd :: forall s. EventM n s () -- ^ Scroll horizontally to the end of the viewport. - , vScrollPage :: Direction -> EventM n () + , vScrollPage :: forall s. Direction -> EventM n s () -- ^ Scroll the viewport vertically by one page in -- the specified direction. - , vScrollBy :: Int -> EventM n () + , vScrollBy :: forall s. Int -> EventM n s () -- ^ Scroll the viewport vertically by the specified -- number of rows or columns depending on the -- orientation of the viewport. - , vScrollToBeginning :: EventM n () + , vScrollToBeginning :: forall s. EventM n s () -- ^ Scroll vertically to the beginning of the viewport. - , vScrollToEnd :: EventM n () + , vScrollToEnd :: forall s. EventM n s () -- ^ Scroll vertically to the end of the viewport. - , setTop :: Int -> EventM n () + , setTop :: forall s. Int -> EventM n s () -- ^ Set the top row offset of the viewport. - , setLeft :: Int -> EventM n () + , setLeft :: forall s. Int -> EventM n s () -- ^ Set the left column offset of the viewport. } -addScrollRequest :: (n, ScrollRequest) -> EventM n () +addScrollRequest :: (n, ScrollRequest) -> EventM n s () addScrollRequest req = EventM $ do - lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s }) + lift $ lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s }) -- | Build a viewport scroller for the viewport with the specified name. viewportScroll :: n -> ViewportScroll n @@ -513,18 +607,59 @@ } -- | Continue running the event loop with the specified application --- state. -continue :: s -> EventM n (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 n (Next s) -halt = return . Halt +halt :: EventM n s () +halt = + EventM $ lift $ lift $ modify $ \es -> es { nextAction = Halt } -- | Suspend the event loop, save the terminal state, and run the -- specified action. When it returns an application state value, restore --- the terminal state, empty the rendering cache, redraw the application --- from the new state, and resume the event loop. -suspendAndResume :: IO s -> EventM n (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,60 +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 Lens.Micro ((.~), (&), (^.)) -import Control.Monad (forM) -import qualified Data.Text as T -import Data.Text.Markup - -import Graphics.Vty (Attr, vertCat, horizCat, text', defAttr) - -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 n 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 n -markup m = - Widget Fixed Fixed $ do - let markupLines = markupToList m - mkLine pairs = do - is <- forM pairs $ \(t, aSrc) -> do - a <- getAttr aSrc - return $ text' a t - if null is - then do - def <- getAttr defAttr - return $ text' def $ T.singleton ' ' - else return $ horizCat is - lineImgs <- mapM mkLine markupLines - return $ emptyResult & imageL .~ vertCat lineImgs diff --git a/src/Brick/Themes.hs b/src/Brick/Themes.hs --- a/src/Brick/Themes.hs +++ b/src/Brick/Themes.hs @@ -6,8 +6,6 @@ -- | Support for representing attribute themes and loading and saving -- theme customizations in INI-style files. -- --- The file format is as follows: --- -- Customization files are INI-style files with two sections, both -- optional: @"default"@ and @"other"@. -- @@ -30,13 +28,14 @@ -- (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@, and @bold@. +-- @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 (@"foo" <> "bar"@), then +-- 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 @@ -49,7 +48,7 @@ -- -- 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 @"list" <> "selected"@ can be +-- a dot. For example, the attribute name @attrName "list" <> attrName "selected"@ can be -- referenced by using the string "list.selected". module Brick.Themes ( CustomAttr(..) @@ -89,7 +88,9 @@ 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 @@ -249,6 +250,7 @@ allStyles = [ ("standout", standout) , ("underline", underline) + , ("strikethrough", strikethrough) , ("reversevideo", reverseVideo) , ("blink", blink) , ("dim", dim) @@ -401,7 +403,7 @@ attrToCustom :: Attr -> CustomAttr attrToCustom a = CustomAttr { customFg = Just $ attrForeColor a - , customBg = 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,7 +1,5 @@ -- | Basic types used by this library. -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Brick.Types ( -- * The Widget type @@ -21,22 +19,34 @@ , vpSize , vpTop , vpLeft + , vpContentSize + , VScrollBarOrientation(..) + , HScrollBarOrientation(..) + , VScrollbarRenderer(..) + , HScrollbarRenderer(..) + , ClickableScrollbarElement(..) - -- * Event-handling types - , EventM(..) - , Next + -- * Event-handling types and functions + , EventM , BrickEvent(..) - , handleEventLensed + , nestEventM + , nestEventM' -- * Rendering infrastructure , RenderM , getContext -- ** The rendering context - , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap, ctxDynBorders) + , Context(ctxAttrName, availWidth, availHeight, windowWidth, windowHeight, ctxBorderStyle, ctxAttrMap, ctxDynBorders) , attrL , availWidthL , availHeightL + , windowWidthL + , windowHeightL + , ctxVScrollBarOrientationL + , ctxVScrollBarRendererL + , ctxHScrollBarOrientationL + , ctxHScrollBarRendererL , ctxAttrMapL , ctxAttrNameL , ctxBorderStyleL @@ -61,6 +71,7 @@ -- * Making lenses , suffixLenses + , suffixLensesWith -- * Dynamic borders , bordersL @@ -73,97 +84,75 @@ -- * Miscellaneous , Size(..) - , Padding(..) , Direction(..) -- * Renderer internals (for benchmarking) , RenderState + + -- * Re-exports for convenience + , get + , gets + , put + , modify + , zoom ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Monoid (Monoid(..)) -#endif - -import Lens.Micro (_1, _2, to, (^.), (&), (.~), Lens') +import Lens.Micro (_1, _2, to, (^.)) import Lens.Micro.Type (Getting) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader +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 Control.Monad.IO.Class import Brick.Types.TH import Brick.Types.Internal +import Brick.Types.EventM import Brick.AttrMap (AttrName, attrMapLookup) --- | The type of padding. -data Padding = Pad Int - -- ^ Pad by the specified number of rows or columns. - | Max - -- ^ Pad up to the number of available rows or columns. - --- | A convenience function for handling events intended for values --- that are targets of lenses in your application state. This function --- obtains the target value of the specified lens, invokes 'handleEvent' --- on it, and stores the resulting transformed value back in the state --- using the lens. -handleEventLensed :: a - -- ^ The state value. - -> Lens' a b - -- ^ The lens to use to extract and store the target - -- of the event. - -> (e -> b -> EventM n b) - -- ^ The event handler. - -> e - -- ^ The event to handle. - -> EventM n a -handleEventLensed v target handleEvent ev = do - newB <- handleEvent ev (v^.target) - return $ v & target .~ newB - --- | The monad in which event handlers run. Although it may be tempting --- to dig into the reader value yourself, just use --- 'Brick.Main.lookupViewport'. -newtype EventM n a = - EventM { runEventM :: ReaderT (EventRO n) (StateT (EventState n) IO) a - } - deriving (Functor, Applicative, Monad, MonadIO) - --- | 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 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 - } - --- | 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 (State (RenderState n)) a +-- | 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 n 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 + EventM $ lift $ lift $ modify $ + \st -> st { nextAction = nextAction stInnerFinal + , esScrollRequests = esScrollRequests stInnerFinal + , cacheInvalidateRequests = cacheInvalidateRequests stInnerFinal + , requestedVisibleNames = requestedVisibleNames stInnerFinal + , vtyContext = vtyContext stInnerFinal + } + return (newSt, actResult) -- | The rendering context's current drawing attribute. -attrL :: forall r. Getting r Context Attr +attrL :: forall r n. Getting r (Context n) Attr attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) instance TerminalLocation (CursorLocation n) where diff --git a/src/Brick/Types/Common.hs b/src/Brick/Types/Common.hs --- a/src/Brick/Types/Common.hs +++ b/src/Brick/Types/Common.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE CPP #-} module Brick.Types.Common ( Location(..) , locL @@ -16,10 +17,14 @@ 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) +data Location = Location { loc :: !(Int, Int) -- ^ (Column, Row) } deriving (Show, Eq, Ord, Read, Generic, NFData) @@ -43,7 +48,7 @@ mempty = origin mappend = (Sem.<>) -data Edges a = Edges { eTop, eBottom, eLeft, eRight :: a } +data Edges a = Edges { eTop, eBottom, eLeft, eRight :: !a } deriving (Eq, Ord, Read, Show, Functor, Generic, NFData) suffixLenses ''Edges 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 @@ -19,10 +19,36 @@ , CursorLocation(..) , cursorLocationL , cursorLocationNameL + , cursorLocationVisibleL + , VScrollBarOrientation(..) + , HScrollBarOrientation(..) + , VScrollbarRenderer(..) + , HScrollbarRenderer(..) + , ClickableScrollbarElement(..) , Context(..) + , ctxAttrMapL + , ctxAttrNameL + , ctxBorderStyleL + , ctxDynBordersL + , ctxVScrollBarOrientationL + , ctxVScrollBarRendererL + , ctxHScrollBarOrientationL + , ctxHScrollBarRendererL + , ctxVScrollBarShowHandlesL + , ctxHScrollBarShowHandlesL + , ctxVScrollBarClickableConstrL + , ctxHScrollBarClickableConstrL + , availWidthL + , availHeightL + , windowWidthL + , windowHeightL + + , Size(..) + , EventState(..) + , VtyContext(..) , EventRO(..) - , Next(..) + , NextAction(..) , Result(..) , Extent(..) , Edges(..) @@ -33,15 +59,22 @@ , dbStyleL, dbAttrL, dbSegmentsL , CacheInvalidateRequest(..) , BrickEvent(..) + , RenderM + , getContext + , lookupReportedExtent + , Widget(..) , rsScrollRequestsL , viewportMapL , clickableNamesL + , reportedExtentsL , renderCacheL , observedNamesL + , requestedVisibleNames_L , vpSize , vpLeft , vpTop + , vpContentSize , imageL , cursorsL , extentsL @@ -51,11 +84,11 @@ ) where -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif - +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 @@ -70,68 +103,195 @@ import Brick.AttrMap (AttrName, AttrMap) import Brick.Widgets.Border.Style (BorderStyle) -data ScrollRequest = HScrollBy Int - | HScrollPage Direction +data ScrollRequest = HScrollBy !Int + | HScrollPage !Direction | HScrollToBeginning | HScrollToEnd - | VScrollBy Int - | VScrollPage Direction + | VScrollBy !Int + | VScrollPage !Direction | VScrollToBeginning | VScrollToEnd - | SetTop Int - | SetLeft Int + | SetTop !Int + | SetLeft !Int deriving (Read, Show, Generic, NFData) +-- | Widget size policies. These policies communicate how a widget uses +-- 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, 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, 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, Eq) +data ViewportType = + Vertical + -- ^ Viewports of this type are scrollable only vertically. + | Horizontal + -- ^ Viewports of this type are scrollable only horizontally. + | Both + -- ^ Viewports of this type are scrollable vertically and horizontally. + deriving (Show, Eq) data CacheInvalidateRequest n = InvalidateSingle n | InvalidateEntire deriving (Ord, Eq) -data EventState n = ES { esScrollRequests :: [(n, ScrollRequest)] - , cacheInvalidateRequests :: S.Set (CacheInvalidateRequest n) - } +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) - , extentOffset :: Location +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 - deriving Functor +data NextAction = + Continue + | ContinueWithoutRedraw + | Halt -- | Scrolling direction. data Direction = Up @@ -162,52 +322,50 @@ -- ^ The location , cursorLocationName :: !(Maybe n) -- ^ The name of the widget associated with the location + , cursorLocationVisible :: !Bool + -- ^ Whether the cursor should actually be visible } 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 + { bsAccept :: !Bool -- ^ Would this segment be willing to be drawn if a neighbor wanted to -- connect to it? - , bsOffer :: Bool + , bsOffer :: !Bool -- ^ Does this segment want to connect to its neighbor? - , bsDraw :: Bool + , bsDraw :: !Bool -- ^ Should this segment be represented visually? } deriving (Eq, Ord, Read, Show, Generic, NFData) -suffixLenses ''BorderSegment - -- | Information about how to redraw a dynamic border character when it abuts -- another dynamic border character. data DynBorder = DynBorder - { dbStyle :: BorderStyle + { dbStyle :: !BorderStyle -- ^ The 'Char's to use when redrawing the border. Also used to filter -- connections: only dynamic borders with equal 'BorderStyle's will connect -- to each other. - , dbAttr :: Attr + , dbAttr :: !Attr -- ^ What 'Attr' to use to redraw the border character. Also used to filter -- connections: only dynamic borders with equal 'Attr's will connect to -- each other. - , dbSegments :: Edges BorderSegment + , dbSegments :: !(Edges BorderSegment) } deriving (Eq, Read, Show, Generic, NFData) -suffixLenses ''DynBorder - -- | 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 + Result { image :: !Image -- ^ The final rendered image for a widget - , cursors :: [CursorLocation n] + , cursors :: ![CursorLocation n] -- ^ The list of reported cursor positions for the -- application to choose from - , visibilityRequests :: [VisibilityRequest] + , visibilityRequests :: ![VisibilityRequest] -- ^ The list of visibility requests made by widgets rendered -- while rendering this one (used by viewports) - , extents :: [Extent n] + , extents :: ![Extent n] -- Programmer's note: we don't try to maintain the invariant that -- the size of the borders closely matches the size of the 'image' -- field. Most widgets don't need to care about borders, and so they @@ -220,61 +378,88 @@ -- If you're writing a widget, this should make it easier for you to -- do so; but beware this lack of invariant if you are consuming -- widgets. - , borders :: BorderMap DynBorder + , borders :: !(BorderMap DynBorder) -- ^ Places where we may rewrite the edge of the image when -- placing this widget next to another one. } deriving (Show, Read, Generic, NFData) -suffixLenses ''Result - emptyResult :: Result n -emptyResult = Result emptyImage [] [] [] BM.empty +emptyResult = + Result { image = emptyImage + , cursors = [] + , visibilityRequests = [] + , extents = [] + , borders = BM.empty + } -- | The type of events. -data BrickEvent n e = VtyEvent Event +data BrickEvent n e = VtyEvent !Event -- ^ The event was a Vty event. - | AppEvent e + | AppEvent !e -- ^ The event was an application event. - | MouseDown n Button [Modifier] Location + | MouseDown !n !Button ![Modifier] !Location -- ^ A mouse-down event on the specified region was -- received. The 'n' value is the resource name of -- the clicked widget (see 'clickable'). - | MouseUp n (Maybe Button) Location + | MouseUp !n !(Maybe Button) !Location -- ^ A mouse-up event on the specified region was -- received. The 'n' value is the resource name of -- the clicked widget (see 'clickable'). deriving (Show, Eq, Ord) -data RenderState n = - RS { viewportMap :: M.Map n Viewport - , rsScrollRequests :: [(n, ScrollRequest)] - , observedNames :: !(S.Set n) - , renderCache :: M.Map n (Result n) - , clickableNames :: [n] - } deriving (Read, Show, Generic, NFData) - -data EventRO n = EventRO { eventViewportMap :: M.Map n Viewport - , eventVtyHandle :: Vty - , latestExtents :: [Extent n] - , oldState :: RenderState n +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 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 - , ctxDynBorders :: Bool +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)) } - deriving Show 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,5 +1,6 @@ module Brick.Types.TH ( suffixLenses + , suffixLensesWith ) where @@ -7,13 +8,18 @@ import qualified Language.Haskell.TH.Lib as TH import Lens.Micro ((&), (.~)) -import Lens.Micro.TH (DefName(..), makeLensesWith, lensRules, lensField) +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 Lens.Micro ((&), (%~)) +#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) +#endif import Graphics.Vty import Brick.Types.Internal (Location(..), CursorLocation(..), cursorLocationL) @@ -50,9 +53,14 @@ 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 n -> Location -> CursorLocation n diff --git a/src/Brick/Widgets/Border.hs b/src/Brick/Widgets/Border.hs --- a/src/Brick/Widgets/Border.hs +++ b/src/Brick/Widgets/Border.hs @@ -20,16 +20,17 @@ -- * Attribute names , borderAttr + , hBorderAttr + , vBorderAttr -- * Utility , joinableBorder ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) #endif - import Lens.Micro ((^.), (&), (.~), to) import Graphics.Vty (imageHeight, imageWidth) @@ -43,8 +44,16 @@ -- | The top-level border attribute name. borderAttr :: AttrName -borderAttr = "border" +borderAttr = attrName "border" +-- | The horizontal border attribute name. Inherits from 'borderAttr'. +hBorderAttr :: AttrName +hBorderAttr = borderAttr <> attrName "horizontal" + +-- | The vertical border attribute name. Inherits from 'borderAttr'. +vBorderAttr :: AttrName +vBorderAttr = borderAttr <> attrName "vertical" + -- | Draw the specified border element using the active border style -- using 'borderAttr'. -- @@ -99,7 +108,8 @@ $ vLimit (middleResult^.imageL.to imageHeight + 2) $ total --- | A horizontal border. Fills all horizontal space. +-- | A horizontal border. Fills all horizontal space. Draws using +-- 'hBorderAttr'. hBorder :: Widget n hBorder = withAttr borderAttr $ Widget Greedy Fixed $ do @@ -109,7 +119,8 @@ db <- dynBorderFromDirections (Edges False False True True) let dynBorders = BM.insertH mempty (Run w db) $ BM.emptyCoordinates (Edges 0 0 0 (w-1)) - setDynBorders dynBorders $ render $ vLimit 1 $ fill (bsHorizontal bs) + setDynBorders dynBorders $ render $ withAttr hBorderAttr + $ vLimit 1 $ fill (bsHorizontal bs) -- | A horizontal border with a label placed in the center of the -- border. Fills all horizontal space. @@ -121,7 +132,8 @@ res <- render $ vLimit 1 label render $ hBox [hBorder, Widget Fixed Fixed (return res), hBorder] --- | A vertical border. Fills all vertical space. +-- | A vertical border. Fills all vertical space. Draws using +-- 'vBorderAttr'. vBorder :: Widget n vBorder = withAttr borderAttr $ Widget Fixed Greedy $ do @@ -131,7 +143,8 @@ db <- dynBorderFromDirections (Edges True True False False) let dynBorders = BM.insertV mempty (Run h db) $ BM.emptyCoordinates (Edges 0 (h-1) 0 0) - setDynBorders dynBorders $ render $ hLimit 1 $ fill (bsVertical bs) + setDynBorders dynBorders $ render $ withAttr vBorderAttr + $ hLimit 1 $ fill (bsVertical bs) -- | Initialize a 'DynBorder'. It will be 'bsDraw'n and 'bsOffer'ing -- in the given directions to begin with, and accept join offers from 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,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} -- | This module provides styles for borders as used in terminal 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 @@ -60,7 +60,7 @@ c <- getContext let rWidth = result^.imageL.to imageWidth rHeight = result^.imageL.to imageHeight - remainder = max 0 $ c^.availWidthL - (leftPaddingAmount * 2) + remainder = max 0 $ c^.availWidthL - (rWidth + (leftPaddingAmount * 2)) leftPaddingAmount = max 0 $ (c^.availWidthL - rWidth) `div` 2 rightPaddingAmount = max 0 $ leftPaddingAmount + remainder leftPadding = charFill (c^.attrL) ch leftPaddingAmount rHeight 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 @@ -4,1125 +4,1847 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} --- | 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 - , padLeft - , padRight - , padTop - , padBottom - , padLeftRight - , padTopBottom - , padAll - - -- * Box layout - , (<=>) - , (<+>) - , hBox - , vBox - - -- * Limits - , hLimit - , hLimitPercent - , vLimit - , vLimitPercent - , setAvailableSize - - -- * Attribute management - , withDefAttr - , modifyDefAttr - , withAttr - , forceAttr - , overrideAttr - , updateAttrMap - - -- * Border style management - , withBorderStyle - , joinBorders - , separateBorders - , freezeBorders - - -- * Cursor placement - , showCursor - - -- * Naming - , Named(..) - - -- * Translation - , translateBy - - -- * Cropping - , cropLeftBy - , cropRightBy - , cropTopBy - , cropBottomBy - - -- * Extent reporting - , reportExtent - , clickable - - -- * Scrollable viewports - , viewport - , visible - , visibleRegion - , unsafeLookupViewport - , cached - - -- ** Adding offsets to cursor positions and visibility requests - , addResultOffset - - -- ** Cropping results - , cropToContext - ) -where - -#if MIN_VERSION_base(4,8,0) -import Data.Monoid ((<>)) -#else -import Control.Applicative -import Data.Monoid ((<>), mempty) -#endif - -import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, each, to, Lens') -import Lens.Micro.Mtl (use, (%=)) -import Control.Monad ((>=>),when) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class (lift) -import qualified Data.Foldable as F -import qualified Data.Text as T -import qualified Data.DList as DL -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 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.empty) <$> render p - --- | The empty widget. -emptyWidget :: Widget n -emptyWidget = raw V.emptyImage - --- | Add an offset to all cursor locations, visbility 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 o) -> Extent n (off <> l) sz o) - -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'). -reportExtent :: 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 (Location (0, 0)) - sz = ( result^.imageL.to V.imageWidth - , result^.imageL.to V.imageHeight - ) - return $ result & extentsL %~ (ext:) - --- | Request mouse click events on the specified widget. -clickable :: 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 - --- | Take a substring capable of fitting into the number of specified --- columns. This function takes character column widths into --- consideration. -takeColumns :: Int -> String -> String -takeColumns _ "" = "" -takeColumns numCols (c:cs) = - let w = V.safeWcwidth c - in if w == numCols - then [c] - else if w < numCols - then c : takeColumns (numCols - w) cs - else "" - --- | 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 escapes. -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 escapes. -strWrapWith :: WrapSettings -> String -> Widget n -strWrapWith settings t = txtWrapWith settings $ T.pack t - -safeTextWidth :: T.Text -> Int -safeTextWidth = V.safeWcswidth . T.unpack - --- | Make a widget from text, but wrap the words in the input's lines at --- the available width using the default wrapping settings. The input --- text should not contain escapes. -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 escapes. -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 - [one] -> return $ emptyResult & imageL .~ (V.text' (c^.attrL) one) - multiple -> - let maxLength = maximum $ safeTextWidth <$> multiple - lineImgs = lineImg <$> multiple - lineImg lStr = V.text' (c^.attrL) - (lStr <> T.replicate (maxLength - safeTextWidth lStr) " ") - in return $ emptyResult & imageL .~ (V.vertCat lineImgs) - --- | Build a widget from a 'String'. 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 --- reinput string should not contain escapes. -str :: String -> Widget n -str s = - Widget Fixed Fixed $ do - c <- getContext - let theLines = fixEmpty <$> (dropUnused . lines) s - fixEmpty :: String -> String - fixEmpty [] = " " - fixEmpty l = l - dropUnused l = takeColumns (availWidth c) <$> take (availHeight c) l - case force theLines of - [] -> return emptyResult - [one] -> return $ emptyResult & imageL .~ (V.string (c^.attrL) one) - multiple -> - let maxLength = maximum $ V.safeWcswidth <$> multiple - lineImgs = lineImg <$> multiple - lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - V.safeWcswidth lStr) ' ') - in return $ emptyResult & imageL .~ (V.vertCat lineImgs) - --- | Build a widget from a 'T.Text' value. Behaves the same as 'str' --- 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 --- reinput text should not contain escapes. -txt :: T.Text -> Widget n -txt = str . T.unpack - --- | 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 = attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL) `V.withURL` url - withReaderT (& ctxAttrMapL %~ setDefaultAttr attr) (render p) - --- | 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). -{-# 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). -{-# 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 Int - , contextSecondary :: Lens' Context Int - , imagePrimary :: V.Image -> Int - , imageSecondary :: V.Image -> Int - , limitPrimary :: Int -> Widget n -> Widget n - , limitSecondary :: Int -> Widget n -> Widget n - , primaryWidgetSize :: Widget n -> Size - , concatenatePrimary :: [V.Image] -> V.Image - , concatenateSecondary :: [V.Image] -> V.Image - , 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 - , limitSecondary = hLimit - , 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 - , limitSecondary = vLimit - , 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 - - let availPrimary = c^.(contextPrimary br) - availSecondary = c^.(contextSecondary br) - - renderHis _ prev [] = return $ DL.toList prev - renderHis remainingPrimary prev ((i, prim):rest) = do - result <- render $ limitPrimary br remainingPrimary - $ limitSecondary br availSecondary - $ cropToContext prim - renderHis (remainingPrimary - (result^.imageL.(to $ imagePrimary br))) - (DL.snoc prev (i, result)) rest - - renderedHis <- renderHis availPrimary DL.empty 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 - rest = remainingPrimary - (primaryPerLow * length ls) - secondaryPerLow = c^.(contextSecondary br) - primaries = replicate rest (primaryPerLow + 1) <> - replicate (length ls - rest) primaryPerLow - - 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) - (imageRewrites, newBorders) = catAllBorders br (borders <$> allTranslatedResults) - rewrittenImages = zipWith (rewriteImage br) imageRewrites allImages - paddedImages = padImage <$> rewrittenImages - - cropResultToContext $ Result (concatenatePrimary br paddedImages) - (concat $ cursors <$> allTranslatedResults) - (concat $ visibilityRequests <$> allTranslatedResults) - (concat $ 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 accomodate 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 synch 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 = img - | otherwise = concatenatePrimary br - [ go loRewrite (splitLoPrimary br 1 img) - , splitHiPrimary br 1 img - ] - rewriteHi img - | I.null hiRewrite = 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 = - 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 = - Widget Fixed (vSize p) $ do - let w = clamp 0 100 w' - ctx <- getContext - let usableWidth = ctx^.availWidthL - widgetWidth = round (toRational usableWidth * (toRational w / 100)) - withReaderT (availWidthL %~ (min widgetWidth)) $ render $ cropToContext p - --- | Limit the space available to the specified widget to the specified --- number of rows. This is important for constraining the vertical --- growth of otherwise-greedy widgets. This is non-greedy vertically and --- defers to the limited widget horizontally. -vLimit :: Int -> Widget n -> Widget n -vLimit h p = - Widget (hSize p) Fixed $ - withReaderT (availHeightL %~ (min h)) $ render $ cropToContext p - --- | 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 = - Widget (vSize p) Fixed $ do - let h = clamp 0 100 h' - ctx <- getContext - let usableHeight = ctx^.availHeightL - widgetHeight = round (toRational usableHeight * (toRational h / 100)) - withReaderT (availHeightL %~ (min widgetHeight)) $ render $ cropToContext p - --- | Set the rendering context height and width for this widget. This --- is useful for relaxing the rendering size constraints on e.g. layer --- widgets where cropping to the screen size is undesirable. -setAvailableSize :: (Int, Int) -> Widget n -> Widget n -setAvailableSize (w, h) p = - Widget Fixed Fixed $ - withReaderT (\c -> c & availHeightL .~ h & availWidthL .~ w) $ - render $ cropToContext p - --- | 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 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 --- its new default attribute to the one that we get by looking up the --- specified attribute name in the map and then modifying it with the --- specified function. -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 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 n -> Widget n -withDefAttr an p = - Widget (hSize p) (vSize p) $ do - c <- getContext - withReaderT (& ctxAttrMapL %~ (setDefaultAttr (attrMapLookup an (c^.ctxAttrMapL)))) (render p) - --- | When rendering the specified widget, update the attribute map with --- the specified transformation. -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. -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) - --- | Override the lookup of 'targetName' to return the attribute value --- associated with 'fromName' when rendering the specified widget. --- See also 'mapAttrName'. -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)) - --- | 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 - 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 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 - return $ result & imageL %~ cropped - --- | 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 - 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 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 - return $ result & imageL %~ cropped - --- | 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) $ do - result <- render p - return $ result & cursorsL %~ (CursorLocation cloc (Just n):) - -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 - --- | Render the specified widget. If the widget has an entry in the --- rendering cache using the specified name as the cache key, use the --- rendered version from the cache instead. If not, render the widget --- and update 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 prevResult -> return prevResult - Nothing -> do - wResult <- render w - cacheUpdate n wResult - return wResult - -cacheLookup :: (Ord n) => n -> RenderM n (Maybe (Result n)) -cacheLookup n = do - cache <- lift $ gets (^.renderCacheL) - return $ M.lookup n cache - -cacheUpdate :: (Ord n) => n -> Result n -> RenderM n () -cacheUpdate n r = lift $ modify (& renderCacheL %~ M.insert n r) - --- | 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, 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. -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 - -- 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. - 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 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) - let release = case typ of - Vertical -> vRelease - Horizontal -> hRelease - 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 - 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. - 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 - - -- 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 $ cropToContext - $ padBottom Max - $ padRight Max - $ Widget Fixed Fixed - $ return $ translated & visibilityRequestsL .~ mempty +{-# 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 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 @@ -5,21 +5,25 @@ -- dialog title, if any, as well as its body and buttons. -- -- Note that this dialog is really for simple use cases where you want --- to get the user's answer to a question, such as "Would you like --- to save changes before quitting?" If you require something more --- sophisticated, you'll need to build it yourself. You might also --- consider seeing the 'Brick.Forms' module for help with input --- management, and see the implementation of this module to see how to --- reproduce a dialog-style UI. +-- to get the user's answer to a question, such as "Would you like to +-- save changes before quitting?" As is typical in such cases, we assume +-- that this dialog box is used modally, meaning that while it is open +-- it is has exclusive input focus until it is closed. +-- +-- If you require something more sophisticated, you'll need to build it +-- yourself. You might also consider seeing the 'Brick.Forms' module for +-- help with input management and see the implementation of this module +-- to see how to reproduce a dialog-style UI. module Brick.Widgets.Dialog ( Dialog , dialogTitle , dialogButtons - , dialogSelectedIndex , dialogWidth -- * Construction and rendering , dialog , renderDialog + , getDialogFocus + , setDialogFocus -- * Handling events , handleDialogEvent -- * Getting a dialog's current value @@ -30,24 +34,20 @@ , buttonSelectedAttr -- * Lenses , dialogButtonsL - , dialogSelectedIndexL , dialogWidthL , dialogTitleL ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Lens.Micro +import Lens.Micro.Mtl ((%=)) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif -import Data.List (intersperse) +import Data.List (intersperse, find) import Graphics.Vty.Input (Event(..), Key(..)) -import Brick.Util (clamp) +import Brick.Focus import Brick.Types import Brick.Widgets.Core import Brick.Widgets.Center @@ -63,71 +63,91 @@ -- -- * Tab or Right Arrow: select the next button -- * Shift-tab or Left Arrow: select the previous button -data Dialog a = - Dialog { dialogTitle :: Maybe String +data Dialog a n = + Dialog { dialogTitle :: Maybe (Widget n) -- ^ The dialog title - , dialogButtons :: [(String, a)] - -- ^ The dialog button labels and values - , dialogSelectedIndex :: Maybe Int - -- ^ The currently selected dialog button index (if any) + , dialogButtons :: [(String, n, a)] + -- ^ The dialog buttons' labels, resource names, and values , dialogWidth :: Int -- ^ The maximum width of the dialog + , dialogFocus :: FocusRing n + -- ^ The focus ring for the dialog's buttons } suffixLenses ''Dialog -handleDialogEvent :: Event -> Dialog a -> EventM n (Dialog a) -handleDialogEvent ev d = - return $ case ev of - EvKey (KChar '\t') [] -> nextButtonBy 1 True d - EvKey KBackTab [] -> nextButtonBy (-1) True d - EvKey KRight [] -> nextButtonBy 1 False d - EvKey KLeft [] -> nextButtonBy (-1) False d - _ -> d +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 :: Maybe String +dialog :: (Eq n) + => Maybe (Widget n) -- ^ The dialog title - -> Maybe (Int, [(String, a)]) - -- ^ The currently-selected button index (starting at zero) and - -- the button labels and values to use + -> Maybe (n, [(String, n, a)]) + -- ^ The currently-selected button resource name and the button + -- labels, resource names, and values to use for each button, + -- respectively -> Int -- ^ The maximum width of the dialog - -> Dialog a + -> Dialog a n dialog title buttonData w = - let (buttons, idx) = case buttonData of - Nothing -> ([], Nothing) - Just (_, []) -> ([], Nothing) - Just (i, bs) -> (bs, Just $ clamp 0 (length bs - 1) i) - in Dialog title buttons idx w + let (r, buttons) = case buttonData of + Nothing -> + (focusRing [], []) + Just (focName, entries) -> + let ns = (\(_, n, _) -> n) <$> entries + in (focusSetCurrent focName $ focusRing ns, entries) + in Dialog title buttons w r -- | The default attribute of the dialog dialogAttr :: AttrName -dialogAttr = "dialog" +dialogAttr = attrName "dialog" -- | The default attribute for all dialog buttons buttonAttr :: AttrName -buttonAttr = "button" +buttonAttr = attrName "button" -- | The attribute for the selected dialog button (extends 'dialogAttr') buttonSelectedAttr :: AttrName -buttonSelectedAttr = buttonAttr <> "selected" +buttonSelectedAttr = buttonAttr <> attrName "selected" -- | Render a dialog with the specified body widget. This renders the -- dialog as a layer, which makes this suitable as a top-level layer in -- your rendering function to be rendered on top of the rest of your -- interface. -renderDialog :: Dialog a -> Widget n -> Widget n +renderDialog :: (Ord n) => Dialog a n -> Widget n -> Widget n renderDialog d body = let buttonPadding = str " " - mkButton (i, (s, _)) = let att = if Just i == d^.dialogSelectedIndexL - then buttonSelectedAttr - else buttonAttr - in withAttr att $ str $ " " <> s <> " " + foc = focusGetCurrent $ dialogFocus d + mkButton (s, n, _) = + let att = if Just n == foc + then buttonSelectedAttr + else buttonAttr + csr = if Just n == foc + then putCursor n (Location (1,0)) + else id + in csr $ + clickable n $ + withAttr att $ + str $ " " <> s <> " " buttons = hBox $ intersperse buttonPadding $ - mkButton <$> (zip [0..] (d^.dialogButtonsL)) + mkButton <$> (d^.dialogButtonsL) - doBorder = maybe border borderWithLabel (str <$> d^.dialogTitleL) + doBorder = maybe border borderWithLabel (d^.dialogTitleL) in centerLayer $ withDefAttr dialogAttr $ hLimit (d^.dialogWidthL) $ @@ -136,24 +156,12 @@ , hCenter buttons ] -nextButtonBy :: Int -> Bool -> Dialog a -> Dialog a -nextButtonBy amt wrapCycle d = - let numButtons = length $ d^.dialogButtonsL - in if numButtons == 0 then d - else case d^.dialogSelectedIndexL of - Nothing -> d & dialogSelectedIndexL .~ (Just 0) - Just i -> d & dialogSelectedIndexL .~ (Just newIndex) - where - addedIndex = i + amt - newIndex = if wrapCycle - then addedIndex `mod` numButtons - else max 0 $ min addedIndex $ numButtons - 1 - --- | Obtain the value associated with the dialog's currently-selected --- button, if any. This function is probably what you want when someone --- presses 'Enter' in a dialog. -dialogSelection :: Dialog a -> Maybe a -dialogSelection d = - case d^.dialogSelectedIndexL of - Nothing -> Nothing - Just i -> Just $ ((d^.dialogButtonsL) !! i)^._2 +-- | Obtain the resource name and value associated with the dialog's +-- currently-selected button, if any. The result of this function is +-- probably what you want when someone presses 'Enter' in a dialog. +dialogSelection :: (Eq n) => Dialog a n -> Maybe (n, a) +dialogSelection d = do + n' <- focusGetCurrent $ dialogFocus d + let matches (_, n, _) = n == n' + (_, n, a) <- find matches (d^.dialogButtonsL) + return (n, a) 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 @@ -25,6 +25,7 @@ , editorText -- * Reading editor contents , getEditContents + , getCursorPosition -- * Handling events , handleEditorEvent -- * Editing text @@ -36,6 +37,8 @@ -- * Attributes , editAttr , editFocusedAttr + -- * UTF-8 decoding of editor pastes + , DecodeUtf8(..) ) where @@ -45,9 +48,13 @@ import Lens.Micro import Graphics.Vty (Event(..), Key(..), Modifier(..)) +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 @@ -55,14 +62,25 @@ -- | 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 +-- * 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 @@ -83,37 +101,75 @@ instance Named (Editor t n) n where getName = editorName -handleEditorEvent :: (Eq t, Monoid t) => Event -> Editor t n -> EventM n (Editor t n) -handleEditorEvent 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 (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 KBS [] -> Z.deletePrevChar - _ -> id - in return $ applyEdit f ed +-- | 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 + -- ^ 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 'String' values +-- | Construct an editor over generic text values editor :: Z.GenericTextZipper a => n -- ^ The editor's name (must be unique) @@ -125,28 +181,34 @@ -> 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. +-- | 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 'Data.Text.Zipper' editing transformation to apply + -- ^ The 'Z.TextZipper' editing transformation to apply -> Editor t n -> Editor t n applyEdit f e = e & editContentsL %~ f -- | The attribute assigned to the editor when it does not have focus. editAttr :: AttrName -editAttr = "edit" +editAttr = attrName "edit" -- | The attribute assigned to the editor when it has focus. Extends -- 'editAttr'. editFocusedAttr :: AttrName -editFocusedAttr = editAttr <> "focused" +editFocusedAttr = editAttr <> attrName "focused" -- | Get the contents of the editor. getEditContents :: Monoid t => Editor t n -> [t] getEditContents e = Z.getText $ e^.editContentsL + +-- | 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 diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs --- a/src/Brick/Widgets/FileBrowser.hs +++ b/src/Brick/Widgets/FileBrowser.hs @@ -3,7 +3,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} --- | This module provids a file browser widget that allows users to +{-# 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@. @@ -53,6 +55,7 @@ , FileInfo(..) , FileStatus(..) , FileType(..) + -- * Making a new file browser , newFileBrowser , selectNonDirectories @@ -64,8 +67,23 @@ , updateFileBrowserSearch , setFileBrowserEntryFilter + -- * Actions + , actionFileBrowserBeginSearch + , actionFileBrowserSelectEnter + , actionFileBrowserSelectCurrent + , actionFileBrowserToggleCurrent + , actionFileBrowserListPageUp + , actionFileBrowserListPageDown + , actionFileBrowserListHalfPageUp + , actionFileBrowserListHalfPageDown + , actionFileBrowserListTop + , actionFileBrowserListBottom + , actionFileBrowserListNext + , actionFileBrowserListPrev + -- * Handling events , handleFileBrowserEvent + , maybeSelectCurrentEntry -- * Rendering , renderFileBrowser @@ -96,15 +114,26 @@ , fileExtensionMatch -- * Lenses - , fileBrowserEntryFilterL , fileBrowserSelectableL , fileInfoFilenameL , fileInfoSanitizedFilenameL , fileInfoFilePathL , fileInfoFileStatusL + , fileInfoLinkTargetTypeL , fileStatusSizeL , fileStatusFileTypeL + -- * Getters + , fileBrowserEntryFilterG + , fileBrowserWorkingDirectoryG + , fileBrowserEntriesG + , fileBrowserLatestResultsG + , fileBrowserSelectedFilesG + , fileBrowserNameG + , fileBrowserSearchStringG + , fileBrowserExceptionG + , fileBrowserSelectableG + -- * Miscellaneous , prettyFileSize @@ -115,9 +144,10 @@ where import qualified Control.Exception as E -import Control.Monad (forM) +import Control.Monad (forM, when) import Control.Monad.IO.Class (liftIO) import Data.Char (toLower, isPrint) +import Data.Foldable (for_) import Data.Maybe (fromMaybe, isJust, fromJust) import qualified Data.Foldable as F import qualified Data.Text as T @@ -125,19 +155,21 @@ import Data.Monoid #endif import Data.Int (Int64) -import Data.List (sortBy, isSuffixOf) +import Data.List (sortBy, isSuffixOf, dropWhileEnd) import qualified Data.Set as Set import qualified Data.Vector as V import Lens.Micro +import Lens.Micro.Mtl ((%=), use) +import Lens.Micro.TH (lensRules, generateUpdateableOptics) import qualified Graphics.Vty as Vty import qualified System.Directory as D -import qualified System.Posix.Files as U -import qualified System.Posix.Types as U +import qualified System.PosixCompat.Files as U +import qualified System.PosixCompat.Types as U import qualified System.FilePath as FP import Text.Printf (printf) import Brick.Types -import Brick.AttrMap (AttrName) +import Brick.AttrMap (AttrName, attrName) import Brick.Widgets.Core import Brick.Widgets.List @@ -171,6 +203,9 @@ -- change the selection function. } +instance Named (FileBrowser n) n where + getName = getName . fileBrowserEntries + -- | File status information. data FileStatus = FileStatus { fileStatusSize :: Int64 @@ -197,6 +232,9 @@ -- ^ 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) @@ -219,6 +257,7 @@ deriving (Read, Show, Eq) suffixLenses ''FileBrowser +suffixLensesWith "G" (lensRules & generateUpdateableOptics .~ False) ''FileBrowser suffixLenses ''FileInfo suffixLenses ''FileStatus @@ -243,8 +282,8 @@ -- executable's current working directory. -> IO (FileBrowser n) newFileBrowser selPredicate name mCwd = do - initialCwd <- case mCwd of - Just path -> return path + initialCwd <- FP.normalise <$> case mCwd of + Just path -> return $ removeTrailingSlash path Nothing -> D.getCurrentDirectory let b = FileBrowser { fileBrowserWorkingDirectory = initialCwd @@ -260,6 +299,22 @@ setWorkingDirectory initialCwd b +-- | Removes any trailing slash(es) from the supplied FilePath (which should +-- indicate a directory). This does not remove a sole slash indicating the root +-- directory. +-- +-- This is done because if the FileBrowser is initialized with an initial working +-- directory that ends in a slash, then selecting the "../" entry to move to the +-- parent directory will cause the removal of the trailing slash, but it will not +-- otherwise cause any change, misleading the user into thinking no action was +-- taken (the disappearance of the trailing slash is unlikely to be noticed). +-- All subsequent parent directory selection operations are processed normally, +-- and the 'fileBrowserWorkingDirectory' never ends in a trailing slash +-- thereafter (except at the root directory). +removeTrailingSlash :: FilePath -> FilePath +removeTrailingSlash "/" = "/" +removeTrailingSlash d = dropWhileEnd (== '/') d + -- | A file entry selector that permits selection of all file entries -- except directories. Use this if you want users to be able to navigate -- directories in the browser. If you want users to be able to select @@ -268,6 +323,10 @@ 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 @@ -277,6 +336,7 @@ 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 @@ -284,6 +344,12 @@ -- 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 @@ -311,10 +377,10 @@ Left (_::E.IOException) -> entries Right parent -> parent : entries - let b' = setEntries allEntries b - return $ b' & fileBrowserWorkingDirectoryL .~ path - & fileBrowserExceptionL .~ exc - & fileBrowserSelectedFilesL .~ mempty + return $ setEntries allEntries b + & fileBrowserWorkingDirectoryL .~ path + & fileBrowserExceptionL .~ exc + & fileBrowserSelectedFilesL .~ mempty parentOf :: FilePath -> IO FileInfo parentOf path = getFileInfo ".." $ FP.takeDirectory path @@ -335,23 +401,50 @@ -- ^ The actual full path to the file or directory to -- inspect. -> IO FileInfo -getFileInfo name fullPath = do - filePath <- D.makeAbsolute fullPath - statusResult <- E.try $ U.getSymbolicLinkStatus filePath +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 - } + let stat = do + status <- statusResult + let U.COff sz = U.fileSize status + return FileStatus { fileStatusFileType = fileTypeFromStatus status + , fileStatusSize = sz + } - return FileInfo { fileInfoFilename = name - , fileInfoFilePath = filePath - , fileInfoSanitizedFilename = sanitizeFilename name - , fileInfoFileStatus = stat - } + 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 @@ -414,7 +507,7 @@ applyFilterAndSearch b = let filterMatch = fromMaybe (const True) (b^.fileBrowserEntryFilterL) searchMatch = maybe (const True) - (\search i -> (T.toLower search `T.isInfixOf` (T.pack $ toLower <$> fileInfoSanitizedFilename i))) + (\search i -> T.toLower search `T.isInfixOf` T.pack (toLower <$> fileInfoSanitizedFilename i)) (b^.fileBrowserSearchStringL) match i = filterMatch i && searchMatch i matching = filter match $ b^.fileBrowserLatestResultsL @@ -499,90 +592,199 @@ -- -- Events handled regardless of mode: -- --- * @Enter@, @Space@: set the file browser's selected entry --- ('fileBrowserSelection') for use by the calling application, --- subject to 'fileBrowserSelectable'. --- * @Ctrl-n@: select the next entry --- * @Ctrl-p@: select the previous entry --- * 'List' navigation keys +-- * @Ctrl-b@: 'actionFileBrowserListPageUp' +-- * @Ctrl-f@: 'actionFileBrowserListPageDown' +-- * @Ctrl-d@: 'actionFileBrowserListHalfPageDown' +-- * @Ctrl-u@: 'actionFileBrowserListHalfPageUp' +-- * @Ctrl-n@: 'actionFileBrowserListNext' +-- * @Ctrl-p@: 'actionFileBrowserListPrev' -- -- Events handled only in normal mode: -- --- * @/@: enter search 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 -handleFileBrowserEvent :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEvent e b = + +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 b - else handleFileBrowserEventNormal e b + then handleFileBrowserEventSearching e + else handleFileBrowserEventNormal e safeInit :: T.Text -> T.Text safeInit t | T.length t == 0 = t | otherwise = T.init t -handleFileBrowserEventSearching :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEventSearching e b = +handleFileBrowserEventSearching :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventSearching e = case e of Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl] -> - return $ updateFileBrowserSearch (const Nothing) b + modify $ updateFileBrowserSearch (const Nothing) Vty.EvKey Vty.KEsc [] -> - return $ updateFileBrowserSearch (const Nothing) b + modify $ updateFileBrowserSearch (const Nothing) Vty.EvKey Vty.KBS [] -> - return $ updateFileBrowserSearch (fmap safeInit) b - Vty.EvKey Vty.KEnter [] -> - updateFileBrowserSearch (const Nothing) <$> - maybeSelectCurrentEntry b + modify $ updateFileBrowserSearch (fmap safeInit) + Vty.EvKey Vty.KEnter [] -> do + maybeSelectCurrentEntry + modify $ updateFileBrowserSearch (const Nothing) Vty.EvKey (Vty.KChar c) [] -> - return $ updateFileBrowserSearch (fmap (flip T.snoc c)) b + modify $ updateFileBrowserSearch (fmap (flip T.snoc c)) _ -> - handleFileBrowserEventCommon e b + handleFileBrowserEventCommon e -handleFileBrowserEventNormal :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEventNormal e b = +handleFileBrowserEventNormal :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventNormal e = case e of Vty.EvKey (Vty.KChar '/') [] -> -- Begin file search - return $ updateFileBrowserSearch (const $ Just "") b + actionFileBrowserBeginSearch Vty.EvKey Vty.KEnter [] -> -- Select file or enter directory - maybeSelectCurrentEntry b + actionFileBrowserSelectEnter Vty.EvKey (Vty.KChar ' ') [] -> - -- Select entry - selectCurrentEntry b + -- Toggle selected status of current entry + actionFileBrowserToggleCurrent _ -> - handleFileBrowserEventCommon e b + handleFileBrowserEventCommon e -handleFileBrowserEventCommon :: (Ord n) => Vty.Event -> FileBrowser n -> EventM n (FileBrowser n) -handleFileBrowserEventCommon e b = +handleFileBrowserEventCommon :: (Ord n) => Vty.Event -> EventM n (FileBrowser n) () +handleFileBrowserEventCommon e = case e of + Vty.EvKey (Vty.KChar 'b') [Vty.MCtrl] -> + actionFileBrowserListPageUp + 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] -> - return $ b & fileBrowserEntriesL %~ listMoveBy 1 + actionFileBrowserListNext Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl] -> - return $ b & fileBrowserEntriesL %~ listMoveBy (-1) + actionFileBrowserListPrev _ -> - handleEventLensed b fileBrowserEntriesL handleListEvent e + zoom fileBrowserEntriesL $ handleListEvent e -maybeSelectCurrentEntry :: FileBrowser n -> EventM n (FileBrowser n) -maybeSelectCurrentEntry b = - case fileBrowserCursor b of - Nothing -> return b - Just entry -> - if fileBrowserSelectable b entry - then return $ b & fileBrowserSelectedFilesL %~ Set.insert (fileInfoFilename entry) - else case fileInfoFileType entry of - Just Directory -> liftIO $ setWorkingDirectory (fileInfoFilePath entry) b - _ -> return b +toggleSelected :: FileInfo -> EventM n (FileBrowser n) () +toggleSelected e = do + sel <- fileBrowserIsSelected e + if sel + then fileBrowserRemoveSelected e + else fileBrowserAddSelected e -selectCurrentEntry :: FileBrowser n -> EventM n (FileBrowser n) -selectCurrentEntry b = - case fileBrowserCursor b of - Nothing -> return b - Just e -> return $ b & fileBrowserSelectedFilesL %~ Set.insert (fileInfoFilename 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 @@ -601,7 +803,7 @@ -- ^ The browser to render. -> Widget n renderFileBrowser foc b = - let maxFilenameLength = maximum $ (length . fileInfoFilename) <$> (b^.fileBrowserEntriesL) + let maxFilenameLength = maximum $ length . fileInfoFilename <$> (b^.fileBrowserEntriesL) cwdHeader = padRight Max $ str $ sanitizeFilename $ fileBrowserWorkingDirectory b selInfo = case listSelectedElement (b^.fileBrowserEntriesL) of @@ -625,7 +827,7 @@ then ", " <> prettyFileSize (fileStatusSize stat) else "" in fileTypeLabel (fileStatusFileType stat) <> maybeSize - in txt $ (T.pack $ fileInfoSanitizedFilename i) <> ": " <> label + in txt $ T.pack (fileInfoSanitizedFilename i) <> ": " <> label maybeSearchInfo = case b^.fileBrowserSearchStringL of Nothing -> emptyWidget @@ -635,14 +837,14 @@ in withDefAttr fileBrowserAttr $ vBox [ withDefAttr fileBrowserCurrentDirectoryAttr cwdHeader - , renderList (renderFileInfo foc maxFilenameLength (b^.fileBrowserSelectedFilesL)) + , renderList (renderFileInfo foc maxFilenameLength (b^.fileBrowserSelectedFilesL) (b^.fileBrowserNameL)) foc (b^.fileBrowserEntriesL) , maybeSearchInfo , withDefAttr fileBrowserSelectionInfoAttr selInfo ] -renderFileInfo :: Bool -> Int -> Set.Set String -> Bool -> FileInfo -> Widget n -renderFileInfo foc maxLen selFiles listSel info = +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) @@ -654,6 +856,7 @@ 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 "") @@ -677,49 +880,49 @@ -- | The base attribute for all file browser attributes. fileBrowserAttr :: AttrName -fileBrowserAttr = "fileBrowser" +fileBrowserAttr = attrName "fileBrowser" -- | The attribute used for the current directory displayed at the top -- of the browser. fileBrowserCurrentDirectoryAttr :: AttrName -fileBrowserCurrentDirectoryAttr = fileBrowserAttr <> "currentDirectory" +fileBrowserCurrentDirectoryAttr = fileBrowserAttr <> attrName "currentDirectory" -- | The attribute used for the entry information displayed at the -- bottom of the browser. fileBrowserSelectionInfoAttr :: AttrName -fileBrowserSelectionInfoAttr = fileBrowserAttr <> "selectionInfo" +fileBrowserSelectionInfoAttr = fileBrowserAttr <> attrName "selectionInfo" -- | The attribute used to render directory entries. fileBrowserDirectoryAttr :: AttrName -fileBrowserDirectoryAttr = fileBrowserAttr <> "directory" +fileBrowserDirectoryAttr = fileBrowserAttr <> attrName "directory" -- | The attribute used to render block device entries. fileBrowserBlockDeviceAttr :: AttrName -fileBrowserBlockDeviceAttr = fileBrowserAttr <> "block" +fileBrowserBlockDeviceAttr = fileBrowserAttr <> attrName "block" -- | The attribute used to render regular file entries. fileBrowserRegularFileAttr :: AttrName -fileBrowserRegularFileAttr = fileBrowserAttr <> "regular" +fileBrowserRegularFileAttr = fileBrowserAttr <> attrName "regular" -- | The attribute used to render character device entries. fileBrowserCharacterDeviceAttr :: AttrName -fileBrowserCharacterDeviceAttr = fileBrowserAttr <> "char" +fileBrowserCharacterDeviceAttr = fileBrowserAttr <> attrName "char" -- | The attribute used to render named pipe entries. fileBrowserNamedPipeAttr :: AttrName -fileBrowserNamedPipeAttr = fileBrowserAttr <> "pipe" +fileBrowserNamedPipeAttr = fileBrowserAttr <> attrName "pipe" -- | The attribute used to render symbolic link entries. fileBrowserSymbolicLinkAttr :: AttrName -fileBrowserSymbolicLinkAttr = fileBrowserAttr <> "symlink" +fileBrowserSymbolicLinkAttr = fileBrowserAttr <> attrName "symlink" -- | The attribute used to render Unix socket entries. fileBrowserUnixSocketAttr :: AttrName -fileBrowserUnixSocketAttr = fileBrowserAttr <> "unixSocket" +fileBrowserUnixSocketAttr = fileBrowserAttr <> attrName "unixSocket" -- | The attribute used for selected entries in the file browser. fileBrowserSelectedAttr :: AttrName -fileBrowserSelectedAttr = fileBrowserAttr <> "selected" +fileBrowserSelectedAttr = fileBrowserAttr <> attrName "selected" -- | A file type filter for use with 'setFileBrowserEntryFilter'. This -- filter permits entries whose file types are in the specified list. @@ -730,6 +933,16 @@ -- 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 = - ('.' : (toLower <$> ext)) `isSuffixOf` (toLower <$> fileInfoFilename i) +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 @@ -4,44 +4,79 @@ , cropToContext , cropResultToContext , renderDynBorder + , renderWidget ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -import Lens.Micro ((^.), (&), (%~)) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Reader -import Data.Maybe (catMaybes) +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, Edges(..)) +import Brick.BorderMap (BorderMap) import qualified Brick.BorderMap as BM -renderFinal :: AttrMap +renderFinal :: (Ord n) + => AttrMap -> [Widget n] -> V.DisplayRegion -> ([CursorLocation n] -> Maybe (CursorLocation n)) -> RenderState n -> (RenderState n, V.Picture, Maybe (CursorLocation n), [Extent n]) -renderFinal aMap layerRenders sz chooseCursor rs = (newRS, picWithBg, theCursor, concat layerExtents) +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 mempty (fst sz) (snd sz) defaultBorderStyle aMap False - pic = V.picForLayers $ uncurry V.resize sz <$> (^.imageL) <$> 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) <$> layerResults - layerExtents = reverse $ (^.extentsL) <$> layerResults + + layerCursors = (^.cursorsL) <$> layersTopmostFirst + layerExtents = reverse $ (^.extentsL) <$> layersTopmostFirst theCursor = chooseCursor $ concat layerCursors -- | After rendering the specified widget, crop its result image to the @@ -58,11 +93,11 @@ & extentsL %~ cropExtents c & bordersL %~ cropBorders c -cropImage :: Context -> V.Image -> V.Image +cropImage :: Context n -> V.Image -> V.Image cropImage c = V.crop (max 0 $ c^.availWidthL) (max 0 $ c^.availHeightL) -cropCursors :: Context -> [CursorLocation n] -> [CursorLocation n] -cropCursors ctx cs = catMaybes $ cropCursor <$> cs +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. @@ -75,42 +110,36 @@ , c^.cursorLocationL.locationColumnL >= ctx^.availWidthL ] -cropExtents :: Context -> [Extent n] -> [Extent n] -cropExtents ctx es = catMaybes $ cropExtent <$> es +cropExtents :: Context n -> [Extent n] -> [Extent n] +cropExtents ctx es = mapMaybe cropExtent es where - -- An extent is cropped in places where it is not within the - -- region described by the context. - -- - -- If its entirety is outside the context region, it is dropped. - -- - -- Otherwise its size and upper left corner are adjusted so that - -- they are contained within the context region. - cropExtent (Extent n (Location (c, r)) (w, h) (Location (oC, oR))) = - -- First, clamp the upper-left corner to at least (0, 0). - let c' = max c 0 - r' = max r 0 - -- Compute deltas for the offset since if the upper-left - -- corner moved, so should the offset. - dc = c' - c - dr = r' - r - -- Then, determine the new lower-right corner based on - -- the clamped corner. - endCol = c' + w - endRow = r' + h - -- Then clamp the lower-right corner based on the - -- context - endCol' = min (ctx^.availWidthL) endCol - endRow' = min (ctx^.availHeightL) endRow - -- Then compute the new width and height from the - -- clamped lower-right corner. - w' = endCol' - c' - h' = endRow' - r' - e = Extent n (Location (c', r')) (w', h') (Location (oC + dc, oR + dr)) - in if w' < 0 || h' < 0 - then Nothing - else Just e + 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 -> BorderMap DynBorder -> BorderMap DynBorder +cropBorders :: Context n -> BorderMap DynBorder -> BorderMap DynBorder cropBorders ctx = BM.crop Edges { eTop = 0 , eBottom = availHeight ctx - 1 @@ -119,17 +148,52 @@ } renderDynBorder :: DynBorder -> V.Image -renderDynBorder db = V.char (dbAttr db) . ($dbStyle db) $ case bsDraw <$> dbSegments db of - -- top bot left right - Edges False False False False -> const ' ' -- dunno lol (but should never happen, so who cares) - 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 +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,8 +1,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable#-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -37,6 +35,7 @@ , listSelectedL , listNameL , listItemHeightL + , listSelectedElementL -- * Accessors , listElements @@ -55,6 +54,8 @@ , listMoveByPages , listMovePageUp , listMovePageDown + , listMoveToBeginning + , listMoveToEnd , listInsert , listRemove , listReplace @@ -62,6 +63,9 @@ , listReverse , listModify + -- * Querying a list + , listFindFirst + -- * Attributes , listAttr , listSelectedAttr @@ -75,20 +79,18 @@ import Prelude hiding (reverse, splitAt) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>), pure) -import Data.Foldable (Foldable, find, toList) -import Data.Traversable (Traversable) -#else +import Control.Applicative ((<|>)) import Data.Foldable (find, toList) -#endif -import Control.Monad.Trans.State (evalState, get, put) +import Control.Monad.State (evalState) -import Lens.Micro ((^.), (^?), (&), (.~), (%~), _2, _head, set) +import Lens.Micro (Traversal', (^.), (^?), (&), (.~), (%~), _2, set) import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (fromMaybe) -import Data.Semigroup (Semigroup, (<>), sconcat) +#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 @@ -193,22 +195,21 @@ -- * Go to last element (End) handleListEvent :: (Foldable t, Splittable t, Ord n) => Event - -> GenericList n t e - -> EventM n (GenericList n t e) -handleListEvent e theList = + -> EventM n (GenericList n t e) () +handleListEvent e = case e of - EvKey KUp [] -> return $ listMoveUp theList - EvKey KDown [] -> return $ listMoveDown theList - EvKey KHome [] -> return $ listMoveTo 0 theList - EvKey KEnd [] -> return $ listMoveTo (length $ listElements theList) theList - EvKey KPageDown [] -> listMovePageDown theList - EvKey KPageUp [] -> listMovePageUp theList - _ -> return theList + EvKey KUp [] -> modify listMoveUp + EvKey KDown [] -> modify listMoveDown + EvKey KHome [] -> modify listMoveToBeginning + EvKey KEnd [] -> modify listMoveToEnd + EvKey KPageDown [] -> listMovePageDown + EvKey KPageUp [] -> listMovePageUp + _ -> return () -- | Enable list movement with the vi keys with a fallback handler if --- none match. Use 'handleListEventVi' 'handleListEvent' in place of --- 'handleListEvent' to add the vi keys bindings to the standard ones. --- Movements handled include: +-- none match. Use 'handleListEventVi' in place of 'handleListEvent' +-- to add the vi keys bindings to the standard ones. Movements handled +-- include: -- -- * Up (k) -- * Down (j) @@ -219,37 +220,48 @@ -- * Go to first element (g) -- * Go to last element (G) handleListEventVi :: (Foldable t, Splittable t, Ord n) - => (Event -> GenericList n t e -> EventM n (GenericList n t e)) + => (Event -> EventM n (GenericList n t e) ()) -- ^ Fallback event handler to use if none of the vi keys -- match. -> Event - -> GenericList n t e - -> EventM n (GenericList n t e) -handleListEventVi fallback e theList = + -> EventM n (GenericList n t e) () +handleListEventVi fallback e = case e of - EvKey (KChar 'k') [] -> return $ listMoveUp theList - EvKey (KChar 'j') [] -> return $ listMoveDown theList - EvKey (KChar 'g') [] -> return $ listMoveTo 0 theList - EvKey (KChar 'G') [] -> return $ listMoveTo (length $ listElements theList) theList - EvKey (KChar 'f') [MCtrl] -> listMovePageDown theList - EvKey (KChar 'b') [MCtrl] -> listMovePageUp theList - EvKey (KChar 'd') [MCtrl] -> listMoveByPages (0.5::Double) theList - EvKey (KChar 'u') [MCtrl] -> listMoveByPages (-0.5::Double) theList - _ -> fallback e theList + EvKey (KChar 'k') [] -> modify listMoveUp + EvKey (KChar 'j') [] -> modify listMoveDown + EvKey (KChar 'g') [] -> modify listMoveToBeginning + EvKey (KChar 'G') [] -> modify listMoveToEnd + EvKey (KChar 'f') [MCtrl] -> listMovePageDown + EvKey (KChar 'b') [MCtrl] -> listMovePageUp + EvKey (KChar 'd') [MCtrl] -> listMoveByPages (0.5::Double) + EvKey (KChar 'u') [MCtrl] -> listMoveByPages (-0.5::Double) + _ -> fallback e +-- | Move the list selection to the first element in the list. +listMoveToBeginning :: (Foldable t, Splittable t) + => 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 when -- the list does not have focus. Extends 'listAttr'. listSelectedAttr :: AttrName -listSelectedAttr = listAttr <> "selected" +listSelectedAttr = listAttr <> attrName "selected" -- | The attribute used only for the currently-selected list item when -- the list has focus. Extends 'listSelectedAttr'. listSelectedFocusedAttr :: AttrName -listSelectedFocusedAttr = listSelectedAttr <> "focused" +listSelectedFocusedAttr = listSelectedAttr <> attrName "focused" -- | Construct a list in terms of container 't' with element type 'e'. list :: (Foldable t) @@ -461,9 +473,8 @@ listMoveUp = listMoveBy (-1) -- | Move the list selected index up by one page. -listMovePageUp - :: (Foldable t, Splittable t, Ord n) - => GenericList n t e -> EventM n (GenericList n t e) +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, @@ -475,23 +486,22 @@ -- | Move the list selected index down by one page. listMovePageDown :: (Foldable t, Splittable t, Ord n) - => GenericList n t e - -> EventM n (GenericList n t e) + => EventM n (GenericList n t e) () listMovePageDown = listMoveByPages (1::Double) -- | Move the list selected index by some (fractional) number of pages. listMoveByPages :: (Foldable t, Splittable t, Ord n, RealFrac m) => m - -> GenericList n t e - -> EventM n (GenericList n t e) -listMoveByPages pages theList = do + -> EventM n (GenericList n t e) () +listMoveByPages pages = do + theList <- get v <- lookupViewport (theList^.listNameL) case v of - Nothing -> return theList + Nothing -> return () Just vp -> do let nElems = round $ pages * fromIntegral (vp^.vpSize._2) / fromIntegral (theList^.listItemHeightL) - return $ listMoveBy nElems theList + modify $ listMoveBy nElems -- | Move the list selected index. -- @@ -527,7 +537,7 @@ -- 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 evalutes +-- If @pos < 0@, indexes from the end of the list (which evaluates -- 'length' of the list). -- -- Complexity: same as 'splitAt' for the container type. @@ -561,7 +571,7 @@ clamp 0 (if null t then length l - 1 else i) i -- | Set the selected index for a list to the index of the first --- occurence of the specified element if it is in the list, or leave +-- 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. @@ -571,11 +581,26 @@ -> GenericList n t e listMoveToElement e = listFindBy (== e) . set listSelectedL Nothing --- | Set the selected index to the next element matching the --- predicate. If there is no selected element, the search starts at --- the beginning. If no matching element is found, leave the list --- unmodified. +-- | Find the first element in the list that satisfies the specified +-- predicate. If such an element is found, return the resulting index +-- and element. -- +-- /O(n)/. +listFindFirst :: (Semigroup (t e), Splittable t, Traversable t) + => (e -> Bool) + -> GenericList n t e + -> Maybe (Int, e) +listFindFirst f l = + listSelectedElement $ + listFindBy f $ + set listSelectedL Nothing l + +-- | Starting from the currently-selected position, attempt to find +-- and select the next element matching the predicate. If there are no +-- matches for the remainder of the list or if the list has no selection +-- 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) @@ -583,10 +608,34 @@ -> GenericList n t e listFindBy test l = let start = maybe 0 (+1) (l ^. listSelectedL) - (_, t) = splitAt start (l ^. listElementsL) - result = find (test . snd) . zip [0..] . toList $ t - in maybe id (set listSelectedL . Just . (start +) . fst) result l + (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 +-- | 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. @@ -597,13 +646,11 @@ -- listSelectedElement for 'List': O(1) -- listSelectedElement for 'Seq.Seq': O(log(min(i, n - i))) -- @ -listSelectedElement :: (Splittable t, Foldable t) +listSelectedElement :: (Splittable t, Traversable t, Semigroup (t e)) => GenericList n t e -> Maybe (Int, e) -listSelectedElement l = do - sel <- l^.listSelectedL - let (_, xs) = splitAt sel (l ^. listElementsL) - (sel,) <$> toList xs ^? _head +listSelectedElement l = + (,) <$> l^.listSelectedL <*> l^?listSelectedElementL -- | Remove all elements from the list and clear the selection. -- @@ -632,11 +679,16 @@ -- -- Complexity: same as 'traverse' for the container type (typically -- /O(n)/). -listModify :: (Traversable t) +-- +-- Complexity: same as 'listSelectedElementL' for the list's container type. +-- +-- @ +-- listModify for 'List': O(n) +-- listModify for 'Seq.Seq': O(log(min(i, n - i))) +-- @ +-- +listModify :: (Traversable t, Splittable t, Semigroup (t e)) => (e -> e) -> GenericList n t e -> GenericList n t e -listModify f l = - case l ^. listSelectedL of - Nothing -> l - Just j -> l & listElementsL %~ imap (\i e -> if i == j then f e else e) +listModify f = listSelectedElementL %~ f diff --git a/src/Brick/Widgets/ProgressBar.hs b/src/Brick/Widgets/ProgressBar.hs --- a/src/Brick/Widgets/ProgressBar.hs +++ b/src/Brick/Widgets/ProgressBar.hs @@ -3,6 +3,7 @@ -- | This module provides a progress bar widget. module Brick.Widgets.ProgressBar ( progressBar + , customProgressBar -- * Attributes , progressCompleteAttr , progressIncompleteAttr @@ -22,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 @@ -37,18 +38,47 @@ -> Float -- ^ The progress value. Should be between 0 and 1 inclusive. -> Widget n -progressBar mLabel progress = +progressBar = customProgressBar ' ' ' ' + +-- | Draw a progress bar with the specified (optional) label, +-- progress value and custom characters to fill the progress. +-- This fills available horizontal space and is one row high. +-- Please be aware of using wide characters in Brick, +-- see [Wide Character Support and the TextWidth class](https://github.com/jtdaugherty/brick/blob/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 = fromMaybe "" mLabel labelWidth = safeWcswidth label spacesWidth = barWidth - labelWidth - leftPart = replicate (spacesWidth `div` 2) ' ' - rightPart = replicate (barWidth - (labelWidth + length leftPart)) ' ' + leftWidth = spacesWidth `div` 2 + rightWidth = barWidth - labelWidth - leftWidth + completeWidth = round $ progress * toEnum barWidth + + leftCompleteWidth = min leftWidth completeWidth + leftIncompleteWidth = leftWidth - leftCompleteWidth + leftPart = replicate leftCompleteWidth completeChar ++ replicate leftIncompleteWidth incompleteChar + rightCompleteWidth = max 0 (completeWidth - labelWidth - leftWidth) + rightIncompleteWidth = rightWidth - rightCompleteWidth + rightPart = replicate rightCompleteWidth completeChar ++ replicate rightIncompleteWidth incompleteChar + fullBar = leftPart <> label <> rightPart - completeWidth = round $ progress * toEnum (length fullBar) - completePart = take completeWidth fullBar - incompletePart = drop completeWidth fullBar + 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/Text/Markup.hs b/src/Data/Text/Markup.hs deleted file mode 100644 --- a/src/Data/Text/Markup.hs +++ /dev/null @@ -1,90 +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 - , isEmpty - , (@@) - ) -where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -import Data.Monoid -#endif - -import qualified Data.Semigroup as Sem -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 Sem.Semigroup (Markup a) where - (Markup t1) <> (Markup t2) = Markup (t1 `mappend` t2) - -instance Monoid (Markup a) where - mempty = Markup mempty - mappend = (Sem.<>) - -instance (Monoid 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 :: (Monoid a) => T.Text -> Markup a -fromText = (@@ mempty) - --- | Extract the text from markup, discarding the markup metadata. -toText :: (Eq a) => Markup a -> T.Text -toText = T.concat . (fst <$>) . concat . markupToList - --- | Test whether the markup is empty. -isEmpty :: Markup a -> Bool -isEmpty (Markup ls) = null ls - --- | 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 lines. Each line is represented by 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 <$> toLines [] [] thePairs - where - toLines ls cur [] = ls ++ [cur] - toLines ls cur ((ch, val):rest) - | ch == '\n' = toLines (ls ++ [cur]) [] rest - | otherwise = toLines ls (cur ++ [(ch, val)]) rest - - 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 --- a/tests/List.hs +++ b/tests/List.hs @@ -1,14 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} - module List - ( - main - ) where + ( main + ) +where import Prelude hiding (reverse, splitAt) @@ -18,7 +17,9 @@ import Data.Maybe (isNothing) import Data.Monoid (Endo(..)) import Data.Proxy +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) +#endif import qualified Data.Sequence as Seq import qualified Data.Vector as V @@ -29,57 +30,56 @@ import Brick.Widgets.List instance (Arbitrary n, Arbitrary a) => Arbitrary (List n a) where - arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1 - + arbitrary = list <$> arbitrary <*> (V.fromList <$> arbitrary) <*> pure 1 -- List move operations that never modify the underlying list -data ListMoveOp a - = MoveUp - | MoveDown - | MoveBy Int - | MoveTo Int - | MoveToElement a - | FindElement a - deriving (Show) +data ListMoveOp a = + MoveUp + | MoveDown + | MoveBy Int + | MoveTo Int + | MoveToElement a + | FindElement a + deriving (Show) instance Arbitrary a => Arbitrary (ListMoveOp a) where - arbitrary = oneof - [ pure MoveUp - , pure MoveDown - , MoveBy <$> arbitrary - , MoveTo <$> arbitrary - , MoveToElement <$> arbitrary - , FindElement <$> arbitrary - ] + arbitrary = + oneof [ pure MoveUp + , pure MoveDown + , MoveBy <$> arbitrary + , MoveTo <$> arbitrary + , MoveToElement <$> arbitrary + , FindElement <$> arbitrary + ] -- List operations. We don't have "page"-based movement operations -- because these depend on render context (i.e. effect in EventM) -data ListOp a - = Insert Int a - | Remove Int - | Replace Int [a] - | Clear - | Reverse - | ListMoveOp (ListMoveOp a) - deriving (Show) +data ListOp a = + Insert Int a + | Remove Int + | Replace Int [a] + | Clear + | Reverse + | ListMoveOp (ListMoveOp a) + deriving (Show) instance Arbitrary a => Arbitrary (ListOp a) where - arbitrary = frequency - [ (1, Insert <$> arbitrary <*> arbitrary) - , (1, Remove <$> arbitrary) - , (1, Replace <$> arbitrary <*> arbitrary) - , (1, pure Clear) - , (1, pure Reverse) - , (6, arbitrary) - ] + arbitrary = + frequency [ (1, Insert <$> arbitrary <*> arbitrary) + , (1, Remove <$> arbitrary) + , (1, Replace <$> arbitrary <*> arbitrary) + , (1, pure Clear) + , (1, pure Reverse) + , (6, arbitrary) + ] -- Turn a ListOp into a List endomorphism op :: Eq a => ListOp a -> List n a -> List n a op (Insert i a) = listInsert i a op (Remove i) = listRemove i op (Replace i xs) = - -- avoid setting index to Nothing - listReplace (V.fromList xs) (Just i) + -- avoid setting index to Nothing + listReplace (V.fromList xs) (Just i) op Clear = listClear op Reverse = listReverse op (ListMoveOp mo) = moveOp mo @@ -93,63 +93,61 @@ moveOp (MoveToElement a) = listMoveToElement a moveOp (FindElement a) = listFindBy (== a) -applyListOps - :: (Foldable t) - => (op a -> List n a -> List n a) -> t (op a) -> List n a -> List n a +applyListOps :: (Foldable t) + => (op a -> List n a -> List n a) + -> t (op a) + -> List n a + -> List n a applyListOps f = appEndo . foldMap (Endo . f) - -- | Initial selection is always 0 (or Nothing for empty list) prop_initialSelection :: [a] -> Bool prop_initialSelection xs = - list () (V.fromList xs) 1 ^. listSelectedL == - if null xs then Nothing else Just 0 + list () (V.fromList xs) 1 ^. listSelectedL == + if null xs then Nothing else Just 0 -- list operations keep the selected index in bounds -prop_listOpsMaintainSelectedValid - :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_listOpsMaintainSelectedValid :: (Eq a) + => [ListOp a] + -> List n a + -> Bool prop_listOpsMaintainSelectedValid ops l = - let l' = applyListOps op ops l - in - case l' ^. listSelectedL of - -- either there is no selection and list is empty - Nothing -> null l' - -- or the selected index is valid - Just i -> i >= 0 && i < length l' + let l' = applyListOps op ops l + in case l' ^. listSelectedL of + -- either there is no selection and list is empty + Nothing -> null l' + -- or the selected index is valid + Just i -> i >= 0 && i < length l' -- reversing a list keeps the selected element the same -prop_reverseMaintainsSelectedElement - :: (Eq a) => [ListOp a] -> List n a -> Bool +prop_reverseMaintainsSelectedElement :: (Eq a) + => [ListOp a] + -> List n a + -> Bool prop_reverseMaintainsSelectedElement ops l = - let -- apply some random list ops to (probably) set a selected element - l' = applyListOps op ops l - l'' = listReverse l' - in - fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'') + let l' = applyListOps op ops l + l'' = listReverse l' + in fmap snd (listSelectedElement l') == fmap snd (listSelectedElement l'') -- reversing maintains size of list prop_reverseMaintainsSizeOfList :: List n a -> Bool prop_reverseMaintainsSizeOfList l = - length l == length (listReverse l) + length l == length (listReverse l) -- an inserted element may always be found at the given index -- (when target index is clamped to 0 <= n <= len) prop_insert :: (Eq a) => Int -> a -> List n a -> Bool prop_insert i a l = - let - l' = listInsert i a l - i' = clamp 0 (length l) i - in - listSelectedElement (listMoveTo i' l') == Just (i', a) + let l' = listInsert i a l + i' = clamp 0 (length l) i + in listSelectedElement (listMoveTo i' l') == Just (i', a) -- inserting anywhere always increases size of list by 1 prop_insertSize :: (Eq a) => Int -> a -> List n a -> Bool prop_insertSize i a l = - let - l' = listInsert i a l - in - length l' == length l + 1 + let l' = listInsert i a l + in length l' == length l + 1 -- inserting an element and moving to it always succeeds and -- the selected element is the one we inserted. @@ -160,11 +158,9 @@ -- prop_insertMoveTo :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool prop_insertMoveTo ops l i a = - let - l' = listInsert i a (applyListOps op ops l) - sel = listSelectedElement (listMoveToElement a l') - in - fmap snd sel == Just a + let l' = listInsert i a (applyListOps op ops l) + sel = listSelectedElement (listMoveToElement a l') + in fmap snd sel == Just a -- inserting an element and repeatedly seeking it always -- reaches the element we inserted, at the index where we @@ -172,57 +168,38 @@ -- prop_insertFindBy :: (Eq a) => [ListOp a] -> List n a -> Int -> a -> Bool prop_insertFindBy ops l i a = - let - l' = applyListOps op ops l - l'' = set listSelectedL Nothing . listInsert i a $ l' - seeks = converging ((==) `on` (^. listSelectedL)) (listFindBy (== a)) l'' - i' = clamp 0 (length l') i -- we can't have inserted past len - in - (find ((== Just i') . (^. listSelectedL)) seeks >>= listSelectedElement) - == Just (i', a) - --- Find will never decrease the selected index. Note that we don't --- need to handle the 'Nothing' case because ∀a. Nothing < Just a. -prop_findByNonDecreasing :: (Eq a) => [ListOp a] -> List n a -> a -> Bool -prop_findByNonDecreasing ops l a = - let - l' = applyListOps op ops l - l'' = listFindBy (== a) l' - in - l' ^. listSelectedL <= l'' ^. listSelectedL + let l' = applyListOps op ops l + l'' = set listSelectedL Nothing . listInsert i a $ l' + seeks = converging ((==) `on` (^. listSelectedL)) (listFindBy (== a)) l'' + i' = clamp 0 (length l') i -- we can't have inserted past len + in (find ((== Just i') . (^. listSelectedL)) seeks >>= listSelectedElement) == Just (i', a) -- inserting then deleting always yields a list with the original elems prop_insertRemove :: (Eq a) => Int -> a -> List n a -> Bool prop_insertRemove i a l = - let - i' = clamp 0 (length l) i - l' = listInsert i' a l -- pre-clamped - l'' = listRemove i' l' - in - l'' ^. listElementsL == l ^. listElementsL + let i' = clamp 0 (length l) i + l' = listInsert i' a l -- pre-clamped + l'' = listRemove i' l' + in l'' ^. listElementsL == l ^. listElementsL -- deleting in-bounds always reduces size of list by 1 -- deleting out-of-bounds never changes list size prop_remove :: Int -> List n a -> Bool prop_remove i l = - let - len = length l - i' = clamp 0 (len - 1) i - test - | len > 0 && i == i' = (== len - 1) -- i is in bounds - | otherwise = (== len) -- i is out of bounds - in - test (length (listRemove i l)) + let len = length l + i' = clamp 0 (len - 1) i + test + | len > 0 && i == i' = (== len - 1) -- i is in bounds + | otherwise = (== len) -- i is out of bounds + in test (length (listRemove i l)) -- deleting an element and re-inserting it at same position -- gives the original list elements prop_removeInsert :: (Eq a) => Int -> List n a -> Bool prop_removeInsert i l = - let - sel = listSelectedElement (listMoveTo i l) - l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l - in - l' ^. listElementsL == l ^. listElementsL + let sel = listSelectedElement (listMoveTo i l) + l' = maybe id (\(i', a) -> listInsert i' a . listRemove i') sel l + in l' ^. listElementsL == l ^. listElementsL -- Apply @f@ until @test a (f a) == True@, then return @a@. converge :: (a -> a -> Bool) -> (a -> a) -> a -> a @@ -232,64 +209,57 @@ -- intermediate and final values as a list. converging :: (a -> a -> Bool) -> (a -> a) -> a -> [a] converging test f a - | test a (f a) = [a] - | otherwise = a : converging test f (f a) + | test a (f a) = [a] + | otherwise = a : converging test f (f a) -- listMoveUp always reaches 0 (or list is empty) prop_moveUp :: (Eq a) => [ListOp a] -> List n a -> Bool prop_moveUp ops l = - let - l' = applyListOps op ops l - l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l' - len = length l'' - in - maybe (len == 0) (== 0) (l'' ^. listSelectedL) + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveUp l' + len = length l'' + in maybe (len == 0) (== 0) (l'' ^. listSelectedL) -- listMoveDown always reaches end of list (or list is empty) prop_moveDown :: (Eq a) => [ListOp a] -> List n a -> Bool prop_moveDown ops l = - let - l' = applyListOps op ops l - l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l' - len = length l'' - in - maybe (len == 0) (== len - 1) (l'' ^. listSelectedL) + let l' = applyListOps op ops l + l'' = converge ((==) `on` (^. listSelectedL)) listMoveDown l' + len = length l'' + in maybe (len == 0) (== len - 1) (l'' ^. listSelectedL) -- move ops never change the list prop_moveOpsNeverChangeList :: (Eq a) => [ListMoveOp a] -> List n a -> Bool prop_moveOpsNeverChangeList ops l = - let - l' = applyListOps moveOp ops l - in - l' ^. listElementsL == l ^. listElementsL + let l' = applyListOps moveOp ops l + in l' ^. listElementsL == l ^. listElementsL -- If the list is empty, empty selection is used. -- Otherwise, if the specified selected index is not in list bounds, -- zero is used instead. -prop_replaceSetIndex - :: (Eq a) - => [ListOp a] -> List n a -> [a] -> Int -> Bool +prop_replaceSetIndex :: (Eq a) + => [ListOp a] + -> List n a + -> [a] + -> Int + -> Bool prop_replaceSetIndex ops l xs i = - let - v = V.fromList xs - l' = applyListOps op ops l - l'' = listReplace v (Just i) l' - i' = clamp 0 (length v - 1) i - inBounds = i == i' - in - l'' ^. listSelectedL == case (null v, inBounds) of - (True, _) -> Nothing - (False, True) -> Just i - (False, False) -> Just 0 + let v = V.fromList xs + l' = applyListOps op ops l + l'' = listReplace v (Just i) l' + i' = clamp 0 (length v - 1) i + inBounds = i == i' + in l'' ^. listSelectedL == case (null v, inBounds) of + (True, _) -> Nothing + (False, True) -> Just i + (False, False) -> Just 0 -- Replacing with no index always clears the index prop_replaceNoIndex :: (Eq a) => [ListOp a] -> List n a -> [a] -> Bool prop_replaceNoIndex ops l xs = - let - v = V.fromList xs - l' = applyListOps op ops l - in - isNothing (listReplace v Nothing l' ^. listSelectedL) + let v = V.fromList xs + l' = applyListOps op ops l + in isNothing (listReplace v Nothing l' ^. listSelectedL) -- | Move the list selected index. If the index is `Just x`, adjust by the -- specified amount; if it is `Nothing` (i.e. there is no selection) and the @@ -297,26 +267,19 @@ -- `Just (length - 1)` (last element). Subject to validation. prop_moveByWhenNoSelection :: List n a -> Int -> Property prop_moveByWhenNoSelection l amt = - let - l' = l & listSelectedL .~ Nothing - len = length l - expected = if amt > 0 then 0 else len - 1 - in - len > 0 ==> listMoveBy amt l' ^. listSelectedL == Just expected - + let l' = l & listSelectedL .~ Nothing + len = length l + expected = if amt > 0 then 0 else len - 1 + in len > 0 ==> listMoveBy amt l' ^. listSelectedL == Just expected splitAtLength :: (Foldable t, Splittable t) => t a -> Int -> Bool splitAtLength l i = - let - len = length l - (h, t) = splitAt i l - in - length h + length t == len - && length h == clamp 0 len i + let len = length l + (h, t) = splitAt i l + in length h + length t == len && length h == clamp 0 len i -splitAtAppend - :: (Splittable t, Semigroup (t a), Eq (t a)) - => t a -> Int -> Bool +splitAtAppend :: (Splittable t, Semigroup (t a), Eq (t a)) + => t a -> Int -> Bool splitAtAppend l i = uncurry (<>) (splitAt i l) == l prop_splitAtLength_Vector :: [a] -> Int -> Bool @@ -332,16 +295,14 @@ prop_splitAtAppend_Seq = splitAtAppend . Seq.fromList -reverseSingleton - :: forall t a. (Reversible t, Applicative t, Eq (t a)) - => Proxy t -> a -> Bool +reverseSingleton :: forall t a. (Reversible t, Applicative t, Eq (t a)) + => Proxy t -> a -> Bool reverseSingleton _ a = - let l = pure a :: t a - in reverse l == l + let l = pure a :: t a + in reverse l == l -reverseAppend - :: (Reversible t, Semigroup (t a), Eq (t a)) - => t a -> t a -> Bool +reverseAppend :: (Reversible t, Semigroup (t a), Eq (t a)) + => t a -> t a -> Bool reverseAppend l1 l2 = reverse (l1 <> l2) == reverse l2 <> reverse l1 @@ -350,49 +311,63 @@ prop_reverseAppend_Vector :: (Eq a) => [a] -> [a] -> Bool prop_reverseAppend_Vector l1 l2 = - reverseAppend (V.fromList l1) (V.fromList l2) + reverseAppend (V.fromList l1) (V.fromList l2) prop_reverseSingleton_Seq :: (Eq a) => a -> Bool prop_reverseSingleton_Seq = reverseSingleton (Proxy :: Proxy Seq.Seq) prop_reverseAppend_Seq :: (Eq a) => [a] -> [a] -> Bool prop_reverseAppend_Seq l1 l2 = - reverseAppend (Seq.fromList l1) (Seq.fromList l2) - - + reverseAppend (Seq.fromList l1) (Seq.fromList l2) -- Laziness tests. Here we create a custom container type -- that we use to ensure certain operations do not cause the --- whole container to be evaulated. +-- whole container to be evaluated. -- newtype L a = L [a] - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable, Semigroup) instance Splittable L where - splitAt i (L xs) = over both L (Data.List.splitAt i xs) + splitAt i (L xs) = over both L (Data.List.splitAt i xs) -- moveBy positive amount does not evaluate 'length' prop_moveByPosLazy :: Bool prop_moveByPosLazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 - l' = listMoveBy 1 l - in - l' ^. listSelectedL == Just 1 + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 + l' = listMoveBy 1 l + in l' ^. listSelectedL == Just 1 -- listFindBy is lazy prop_findByLazy :: Bool prop_findByLazy = - let - v = L (1:2:3:4:undefined) :: L Int - l = list () v 1 & listSelectedL .~ Nothing - l' = listFindBy even l - l'' = listFindBy even l' - in - l' ^. listSelectedL == Just 1 - && l'' ^. listSelectedL == Just 3 + let v = L (1:2:3:4:undefined) :: L Int + l = list () v 1 & listSelectedL .~ Nothing + l' = listFindBy even l + l'' = listFindBy even l' + in l' ^. listSelectedL == Just 1 && + l'' ^. listSelectedL == Just 3 +prop_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 [] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +14,7 @@ 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 @@ -60,16 +62,16 @@ prop_compare l r = compare l r == compare (lower l) (lower r) prop_applicativeIdentity :: I -> Bool -prop_applicativeIdentity v = (pure id <*> v) == v +prop_applicativeIdentity v = (id <$> v) == v prop_applicativeComposition :: IMap (O -> O) -> IMap (O -> O) -> IMap O -> Bool -prop_applicativeComposition u v w = (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w)) +prop_applicativeComposition u v w = ((.) <$> u <*> v <*> w) == (u <*> (v <*> w)) prop_applicativeHomomorphism :: (O -> O) -> O -> Bool -prop_applicativeHomomorphism f x = (pure f <*> pure x :: I) == pure (f x) +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) == (pure ($ y) <*> u) +prop_applicativeInterchange u y = (u <*> pure y) == (($ y) <$> u) prop_empty :: Bool prop_empty = lower (IMap.empty :: I) == IntMap.empty @@ -111,5 +113,5 @@ main :: IO () main = - (all id <$> sequenceA [$quickCheckAll, List.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