diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ + +Brick changelog +--------------- + +0.1 +--- +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Jonathan Daugherty. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of the contributors may not be used to endorse or + promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,120 @@ +brick +----- + +[![Build Status](https://travis-ci.org/jtdaugherty/brick.png)](https://travis-ci.org/jtdaugherty/brick) + +`brick` is a terminal user interface programming +library written in Haskell, in the style of +[gloss](http://hackage.haskell.org/package/gloss). This means you write +a function that describes how your user interface should look, but the +library takes care of a lot of the book-keeping that so commonly goes +into writing such programs. + +`brick` exposes a declarative API. Unlike most GUI toolkits which +require you to write a long and tedious sequence of "create a widget, +now bind an event handler", `brick` just requires you to describe +your interface -- even the bits that are stateful -- using a set of +declarative combinators. Then you provide a function to transform your +own application state when input (or other kinds of) events arrive. + +Under the hood, this library builds upon [vty](http://hackage.haskell.org/package/vty). + +This library deprecates [vty-ui](https://github.com/jtdaugherty/vty-ui). + +Feature Overview +---------------- + +`brick` comes with a bunch of widget types to get you started: + + * Vertical and horizontal box layout widgets + * Basic single- and multi-line text editor widgets + * List widget + * Progress bar widget + * Simple dialog box widget + * Border-drawing widgets (put borders around or in between things) + * Generic scrollable viewports + * Extensible widget-building API + * (And many more general-purpose layout control combinators) + +In addition, some of `brick`'s more powerful features may not be obvious +right away: + + * All widgets can be arranged in predictable layouts so you don't have + to worry about terminal resizes. + * Most widgets can be made scrollable *for free*. + * Attribute management is flexible and can be customized at runtime on + a per-widget basis. + +`brick` exports [lens](http://github.com/ekmett/lens) and non-`lens` +interfaces for most things, so you can get the full power of `lens` if +you want it or use plain Haskell if you don't. If a `brick` library +function named `thing` has a `lens` version, the `lens` version is named +`thingL`. + +Getting Started +--------------- + +TLDR: + +``` +$ cabal sandbox init +$ cabal install -j -f demos +$ .cabal-sandbox/bin/brick-???-demo +``` + +To get started, see the [first few sections of the brick +user guide](docs/guide.rst). + +Documentation +------------- + +Your documentation options, in recommended order, are: + +* [FAQ](FAQ.md) +* [The brick user guide](docs/guide.rst) +* Haddock (all modules) +* [Demo programs](programs) + +Status +------ + +`brick` is young and may be missing some essential features. There are +some places were I have deliberately chosen to worry about performance +later for the sake of spending more time on the design (and to wait on +performance issues to arise first). `brick` exports an extension API +that makes it possible to make your own packages and widgets. If you +use that, you'll also be helping to test whether the exported interface +is usable and complete! + +The development of this library has revealed some bugs in `vty`, and +I've tried to report those as I go. If they haven't been resolved, +you'll see them arise when using `brick`. + +Reporting bugs +-------------- + +Please file bug reports as GitHub issues. For best results: + + - Include the versions of relevant software packages: your terminal + emulator, `brick`, `ghc`, and `vty` will be the most important + ones. Even better, the output of `cabal freeze` would probably be + helpful in making the problem reproducible. + + - Clearly describe the behavior you expected ... + + - ... and include a mininal demonstration program that exhibits the + behavior you actually observed. + +Contributing +------------ + +If you decide to contribute, that's great! Here are some guidelines you +should consider to make submitting patches easier for all concerned: + + - If you want to take on big things, talk to me first; let's have a + design/vision discussion before you start coding. Create a GitHub + issue and we can use that as the place to hash things out. + - If you make changes, try to make them consistent with the syntactic + conventions I've used in the codebase. + - Please provide Haddock and/or user guide documentation for any + changes you make. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/brick.cabal b/brick.cabal new file mode 100644 --- /dev/null +++ b/brick.cabal @@ -0,0 +1,271 @@ +name: brick +version: 0.1 +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. + . + . + > module Main where + > + > import Brick.Main (simpleMain) + > import Brick.Widgets.Core (Widget, str) + > + > ui :: Widget + > ui = str "Hello, world!" + > + > main :: IO () + > main = simpleMain ui + . + . + To get started, see: + . + * + . + * The + . + * The demonstration programs in the 'programs' directory + . + . + This package deprecates . +license: BSD3 +license-file: LICENSE +author: Jonathan Daugherty +maintainer: Jonathan Daugherty +copyright: (c) Jonathan Daugherty 2015 +category: Graphics +build-type: Simple +cabal-version: >=1.10 +Homepage: https://github.com/jtdaugherty/brick/ +Bug-reports: https://github.com/jtdaugherty/brick/issues + +data-files: README.md, + docs/guide.rst, + CHANGELOG.md + +Source-Repository head + type: git + location: git://github.com/jtdaugherty/brick.git + +Flag demos + Description: Build demonstration programs + Default: False + +library + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind -O3 + hs-source-dirs: src + exposed-modules: + Brick.AttrMap + Brick.Focus + Brick.Main + Brick.Markup + Brick.Types + Brick.Util + Brick.Widgets.Border + Brick.Widgets.Border.Style + Brick.Widgets.Center + Brick.Widgets.Core + Brick.Widgets.Dialog + Brick.Widgets.Edit + Brick.Widgets.List + Brick.Widgets.ProgressBar + Data.Text.Markup + other-modules: + Brick.Types.TH + Brick.Widgets.Internal + + build-depends: base <= 5, + vty >= 5.3.1, + transformers, + data-default, + Diff, + containers, + lens, + vector, + contravariant, + text, + text-zipper >= 0.2.1, + template-haskell + +executable brick-visibility-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: VisibilityDemo.hs + build-depends: base, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-viewport-scroll-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: ViewportScrollDemo.hs + build-depends: base, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-dialog-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: DialogDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-layer-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: LayerDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-suspend-resume-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: SuspendAndResumeDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-padding-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: PaddingDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-attr-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: AttrDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-markup-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: MarkupDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-list-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: ListDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-custom-event-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: CustomEventDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-hello-world-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: HelloWorldDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-edit-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: EditDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens + +executable brick-border-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: BorderDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.3.1, + data-default, + text, + lens diff --git a/docs/guide.rst b/docs/guide.rst new file mode 100644 --- /dev/null +++ b/docs/guide.rst @@ -0,0 +1,824 @@ +Brick User Guide +~~~~~~~~~~~~~~~~ + +.. contents:: `Table of Contents` + +Introduction +============ + +``brick`` is a Haskell library for programming terminal user interfaces. +Its main goal is to make terminal user interface development as painless +and as direct as possible. ``brick`` builds on `vty`_; `vty` provides +the terminal input and output interface and drawing primitives, +while ``brick`` builds on those to provide a high-level application +abstraction and combinators for expressing user interface layouts. + +This documentation is intended to provide a high-level overview of +the library's design along with guidance for using it, but details on +specific functions can be found in the Haddock documentation. + +The process of writing an application using ``brick`` entails writing +two important functions: + +- A *drawing function* that turns your application state into a + specification of how your interface should look, and +- An *event handler* that takes your application state and an input + event and decides whether to change the state or quit the program. + +We write drawing functions in ``brick`` using an extensive set of +primitives and combinators to place text on the screen, set its +attributes (e.g. foreground color), and express layout constraints (e.g. +padding, centering, box layouts, scrolling viewports, etc.). + +These functions get packaged into a structure that we hand off to the +``brick`` library's main event loop. We'll cover that in detail in `The +App Type`_. + +Installation +------------ + +``brick`` can be installed in the "usual way," either by installing +the latest `Hackage`_ release or by cloning the GitHub repository and +building locally. + +To install from Hackage:: + + $ cabal update + $ cabal install brick + +To clone and build locally:: + + $ git clone https://github.com/jtdaugherty/brick.git + $ cd brick + $ cabal sandbox init + $ cabal install -j + +Building the Demonstration Programs +----------------------------------- + +``brick`` includes a large collection of feature-specific demonstration +programs. These programs are not built by default but can be built by +passing the ``demos`` flag to `cabal install`, e.g.:: + + $ cabal install brick -f demos + +Conventions +=========== + +``brick`` has some API conventions worth knowing about as you read this +documentation and as you explore the library source and write your own +programs. + +- Use of `lens`_: ``brick`` uses ``lens`` functions internally and also + exposes lenses for many types in the library. However, if you prefer + not to use the ``lens`` interface in your program, all ``lens`` + interfaces have non-`lens` equivalents exported by the same module. In + general, the "``L``" suffix on something tells you it is a ``lens``; + the name without the "``L``" suffix is the non-`lens` version. You can + get by without using ``brick``'s ``lens`` interface but your life will + probably be much more pleasant once your application state becomes + sufficiently complex if you use lenses to modify it (see + `appHandleEvent: Handling Events`_). +- Attribute names: some modules export attribute names (see `How + Attributes Work`_) associated with user interface elements. These tend + to end in an "``Attr``" suffix (e.g. ``borderAttr``). In addition, + hierarchical relationships between attributes are documented in + Haddock documentation. +- Use of qualified names: in this document, where sensible, I will use + fully-qualified names whenever I mention something for the first time + or whenever I use something that is not part of ``brick``. Use of + names in this way is not intended to produce executable examples, but + rather to guide you in writing your ``import`` statements. + +The App Type +============ + +To use the library we must provide it with a value of type +``Brick.Main.App``. This type is a record type whose fields perform +various functions: + +.. code:: haskell + + data App s e = + App { appDraw :: s -> [Widget] + , appChooseCursor :: s -> [CursorLocation] -> Maybe CursorLocation + , appHandleEvent :: s -> e -> EventM (Next s) + , appStartEvent :: s -> EventM s + , appAttrMap :: s -> AttrMap + , appLiftVtyEvent :: Event -> e + } + +The ``App`` type is polymorphic over two types: your application state +type ``s`` and event type ``e``. + +The application state type is the type of data that will evolve over the +course of the application's execution; we will provide the library with +its starting value and event handling will transform it as the program +executes. + +The event type is the type of events that your event handler +(``appHandleEvent``) will handle. The underlying ``vty`` library +provides ``Graphics.Vty.Event`` and this forms the basis of all events +we will handle with ``brick`` applications. The +``Brick.Main.defaultMain`` function expects an ``App s Event`` since +this is a common case. + +However, we often need to extend our notion of events beyond those +originating from the keyboard. Imagine an application with multiple +threads and network or disk I/O. Such an application will need to have +its own internal events to pass to the event handler as (for example) +network data arrives. To accommodate this we allow an ``App`` to use an +event type of your own design, so long as it provides a constructor for +``vty``'s ``Event`` type (``appLiftVtyEvent``). For more details, see +`Using Your Own Event Type`_. + +The various fields of ``App`` will be described in the sections below. + +To run an ``App``, we pass it to ``Brick.Main.defaultMain`` or +``Brick.Main.customMain`` along with an initial application state value. + +appDraw: Drawing an Interface +----------------------------- + +The value of ``appDraw`` is a function that turns the current +application state into a list of *layers* of type ``Widget``, listed +topmost first, that will make up the interface. Each ``Widget`` gets +turned into a ``vty`` layer and the resulting layers are drawn to the +terminal. + +The ``Widget`` type is the type of *drawing instructions*. The body of +your drawing function will use one or more drawing functions to build or +transform ``Widget`` values to describe your interface. These +instructions will then be executed with respect to three things: + +- The size of the terminal: the size of the terminal determines how many + ``Widget`` values behave. For example, fixed-size ``Widget`` values + such as text strings behave the same under all conditions (and get + cropped if the terminal is too small) but layout combinators such as + ``Brick.Widgets.Core.vBox`` or ``Brick.Widgets.Center.center`` use the + size of the terminal to determine how to lay other widgets out. See + `How Widgets and Rendering Work`_. +- The application's attribute map (``appAttrMap``): drawing functions + requesting the use of attributes cause the attribute map to be + consulted. See `How Attributes Work`_. +- The state of scrollable viewports: the state of any scrollable + viewports on the *previous* drawing will be considered. For more + details, see `Viewports`_. + +The ``appDraw`` function is called when the event loop begins to draw +the application as it initially appears. It is also called right after +an event is processed by ``appHandleEvent``. Even though the function +returns a specification of how to draw the entire screen, the underlying +``vty`` library goes to some trouble to efficiently update only the +parts of the screen that have changed so you don't need to worry about +this. + +Where do I find drawing functions? +********************************** + +The most important module providing drawing functions is +``Brick.Widgets.Core``. Beyond that, any module in the ``Brick.Widgets`` +namespace provides specific kinds of functionality. + +appHandleEvent: Handling Events +------------------------------- + +The value of ``appHandleEvent`` is a function that decides how to modify +the application state as a result of an event. It also decides whether +to continue program execution. The function takes the current +application state and the event and returns the *next application +state*: + +.. code:: haskell + + appHandleEvent :: s -> e -> EventM (Next s) + +The ``EventM`` monad is the event-handling monad. This monad is a +transformer around ``IO``, so you are free to do I/O in this monad by +using ``liftIO``. Beyond I/O, this monad is just used to make scrolling +requests to the renderer (see `Viewports`_). Keep in mind that time +spent blocking in your event handler is time during which your UI is +unresponsive, so consider this when deciding whether to have background +threads do work instead of inlining the work in the event handler. + +The ``Next s`` value describes what should happen after the event +handler is finished. We have three choices: + +* ``Brick.Main.continue s``: continue executing the event loop with the + specified application state ``s`` as the next value. Commonly this is + where you'd modify the state based on the event and return it. +* ``Brick.Main.halt s``: halt the event loop and return the final + application state value ``s``. This state value is returned to the + caller of ``defaultMain`` or ``customMain`` where it can be used prior + to finally exiting ``main``. +* ``Brick.Main.suspendAndResume act``: suspend the ``brick`` event loop + and execute the specified ``IO`` action ``act``. The action ``act`` + must be of type ``IO s``, so when it executes it must return the next + application state. When ``suspendAndResume`` is used, the ``brick`` + event loop is shut down and the terminal state is restored to its + state when the ``brick`` event loop began execution. When it finishes + executing, the event loop will be resumed using the returned state + value. This is useful for situations where your program needs to + suspend your interface and execute some other program that needs to + gain control of the terminal (such as an external editor). + +Using Your Own Event Type +************************* + +Since we often need to communicate application-specific events +beyond input events to the event handler, the ``App`` type is +polymorphic over the event type we want to handle. If we use +``Brick.Main.defaultMain`` to run our ``App``, we have to use +``Graphics.Vty.Event`` as our event type. But if our application has +other event-handling needs, we need to use our own event type. + +To do this, we first define an event type: + +.. code:: haskell + + data CustomEvent = + VtyEvent Graphics.Vty.Event + | CustomEvent1 + | CustomEvent2 + +Our custom event type *must* provide a constructor capable of taking +a ``Graphics.Vty.Event`` value. This allows the ``brick`` event loop +to send us ``vty`` events in the midst of our custom ones. To allow +``brick`` to do this, we provide this constructor as the value of +``appLiftVtyEvent``. This way, ``brick`` can wrap a ``vty`` event using +our custom event type and then pass it to our event handler (which takes +``CustomEvent`` values). In this case we'd set ``appLiftVtyEvent = +VtyEvent``. + +Once we have set ``appLiftVtyEvent`` in this way, we also need to set up +a mechanism for getting our custom events into the ``brick`` event loop +from other threads. To do this we use a ``Control.Concurrent.Chan`` and +call ``Brick.Main.customMain`` instead of ``Brick.Main.defaultMain``: + +.. code:: haskell + + main :: IO () + main = do + eventChan <- Control.Concurrent.newChan + finalState <- customMain (Graphics.Vty.mkVty Data.Default.def) eventChan app initialState + -- Use finalState and exit + +Beyond just the application and its initial state, the ``customMain`` +function lets us have control over how the ``vty`` library is +initialized and how ``brick`` gets custom events to give to our event +handler. ``customMain`` is the entry point into ``brick`` when you need +to use your own event type. + +Starting up: appStartEvent +************************** + +When an application starts, it may be desirable to perform some of +the duties typically only possible when an event has arrived, such as +setting up initial scrolling viewport state. Since such actions can only +be performed in ``EventM`` and since we do not want to wait until the +first event arrives to do this work in ``appHandleEvent``, the ``App`` +type provides ``appStartEvent`` function for this purpose: + +.. code:: haskell + + appStartEvent :: s -> EventM s + +This function takes the initial application state and returns it in +``EventM``, possibly changing it and possibly making viewport requests. +For more details, see `Viewports`_. You will probably just want to use +``return`` as the implementation of this function for most applications. + +appChooseCursor: Placing the Cursor +----------------------------------- + +The rendering process for a ``Widget`` may return information about +where that widget would like to place the cursor. For example, a text +editor will need to report a cursor position. However, since a +``Widget`` may be a composite of many such cursor-placing widgets, we +have to have a way of choosing which of the reported cursor positions, +if any, is the one we actually want to honor. + +To decide which cursor placement to use, or to decide not to show one at +all, we set the ``App`` type's ``appChooseCursor`` function: + +.. code:: haskell + + appChooseCursor :: s -> [CursorLocation] -> Maybe CursorLocation + +The event loop renders the interface and collects the +``Brick.Types.CursorLocation`` values produced by the rendering process +and passes those, along with the current application state, to this +function. Using your application state (to track which text input box +is "focused," say) you can decide which of the locations to return or +return ``Nothing`` if you do not want to show a cursor. + +We decide which location to show by looking at the ``Brick.Types.Name`` +value contained in the ``cursorLocationName`` field. The ``Name`` +value associated with a cursor location will be the ``Name`` of the +``Widget`` that requested it; this is why constructors for widgets like +``Brick.Widgets.Edit.editor`` require a ``Name`` parameter. The ``Name`` +lets us distinguish between many cursor-placing widgets of the same +type. + +``Brick.Main`` provides various convenience functions to make cursor +selection easy in common cases: + +* ``neverShowCursor``: never show any cursor. +* ``showFirstCursor``: always show the first cursor request given; good + for applications with only one cursor-placing widget. +* ``showCursorNamed``: show the cursor with the specified name or + ``Nothing`` if it is not requested. + +Widgets request cursor placement by using the +``Brick.Widgets.Core.showCursor`` combinator. For example, this widget +places a cursor on the first "``o``" in "``foo``" assocated with the +cursor name "``myCursor``": + +.. code:: haskell + + let w = showCursor (Name "myCursor") (Brick.Types.Location (1, 0)) + (Brick.Widgets.Core.str "foobar") + +appAttrMap: Managing Attributes +------------------------------- + +In ``brick`` we use an *attribute map* to assign attibutes to elements +of the interface. Rather than specifying specific attributes when +drawing a widget (e.g. red-on-black text) we specify an *attribute name* +that is an abstract name for the kind of thing we are drawing, e.g. +"keyword" or "e-mail address." We then provide an attribute map which +maps those attribute names to actual attributes. This approach lets us: + +* Change the attributes at runtime, letting the user change the + attributes of any element of the application arbitrarily without + forcing anyone to build special machinery to make this configurable; +* Write routines to load saved attribute maps from disk; +* Provide modular attribute behavior for third-party components, where + we would not want to have to recompile third-party code just to change + attributes, and where we would not want to have to pass in attribute + arguments to third-party drawing functions. + +This lets us put the attribute mapping for an entire app, regardless of +use of third-party widgets, in one place. + +To create a map we use ``Brick.AttrMap.attrMap``, e.g., + +.. code:: haskell + + App { ... + , appAttrMap = const $ attrMap Graphics.Vty.defAttr [(someAttrName, fg blue)] + } + +To use an attribute map, we specify the ``App`` field ``appAttrMap`` as +the function to return the current attribute map each time rendering +occurs. This function takes the current application state, so you may +choose to store the attribute map in your application state. You may +also choose not to bother with that and to just set ``appAttrMap = const +someMap``. + +To draw a widget using an attribute name in the map, use +``Brick.Widgets.Core.withAttr``. For example, this draws a string with a +``blue`` background: + +.. code:: haskell + + let w = withAttr blueBg $ str "foobar" + blueBg = attrName "blueBg" + myMap = attrMap defAttr [ (blueBg, Brick.Util.bg Graphics.Vty.blue) + ] + +For complete details on how attribute maps and attribute names work, see +the Haddock documentation for the ``Brick.AttrMap`` module. See also +`How Attributes Work`_. + +How Widgets and Rendering Work +============================== + +When ``brick`` renders a ``Widget``, the widget's rendering routine is +evaluated to produce a ``vty`` ``Image`` of the widget. The widget's +rendering routine runs with some information called the *rendering +context* that contains: + +* The size of the area in which to draw things +* The name of the current attribute to use to draw things +* The map of attributes to use to look up attribute names +* The active border style to use when drawing borders + +Available Rendering Area +------------------------ + +The most important element in the rendering context is the rendering +area: This part of the context tells the widget being drawn how many +rows and columns are available for it to consume. When rendering begins, +the widget being rendered (i.e. a layer returned by an ``appDraw`` +function) gets a rendering context whose rendering area is the size of +the terminal. This size information is used to let widgets take up that +space if they so choose. For example, a string "Hello, world!" will +always take up one row and 13 columns, but the string "Hello, world!" +*centered* will always take up one row and *all available columns*. + +How widgets use space when rendered is described in two pieces of +information in each ``Widget``: the widget's horizontal and vertical +growth policies. These fields have type ``Brick.Widgets.Core.Size`` and +can have the values ``Fixed`` and ``Greedy``. + +A widget advertising a ``Fixed`` size in a given dimension is a widget +that will always consume the same number of rows or columns no +matter how many it is given. Widgets can advertise different +vertical and horizontal growth policies for example, the +``Brick.Widgets.Border.hCenter`` function centers a widget and is +``Greedy`` horizontally and defers to the widget it centers for vertical +growth behavior. + +These size policies govern the box layout algorithm that is at +the heart of every non-trivial drawing specification. When we use +``Brick.Widgets.Core.vBox`` and ``Brick.Widgets.Core.hBox`` to +lay things out (or use their binary synonyms ``<=>`` and ``<+>``, +respectively), the box layout algorithm looks at the growth policies of +the widgets it receives to determine how to allocate the available space +to them. + +For example, imagine that the terminal window is currently 10 rows high +and 50 columns wide. We wish to render the following widget: + +.. code:: haskell + + let w = (str "Hello," <=> str "World!") + +Rendering this to the terminal will result in "Hello," and "World!" +underneath it, with 8 rows unoccupied by anything. But if we wished to +render a vertical border underneath those strings, we would write: + +.. code:: haskell + + let w = (str "Hello," <=> str "World!" <=> vBorder) + +Rendering this to the terminal will result in "Hello," and "World!" +underneath it, with 8 rows remaining occupied by vertical border +characters ("``|``") one column wide. The vertical border widget is +designed to take up however many rows it was given, but rendering the +box layout algorithm has to be careful about rendering such ``Greedy`` +widgets because the won't leave room for anything else. Since the box +widget cannot know the sizes of its sub-widgets until they are rendered, +the ``Fixed`` widgets get rendered and their sizes are used to determine +how much space is left for ``Greedy`` widgets. + +When using widgets it is important to understand their horizontal and +vertical space behavior by knowing their ``Size`` values. Those should +be made clear in the Haddock documentation. + +Limiting Rendering Area +----------------------- + +If you'd like to use a ``Greedy`` widget but want to limit how much +space it consumes, you can turn it into a ``Fixed`` widget by using +one of the *limiting combinators*, ``Brick.Widgets.Core.hLimit`` and +``Brick.Widgets.Core.vLimit``. These combinators take widgets and turn +them into widgets with a ``Fixed`` size (in the relevant dimension) and +run their rendering functions in a modified rendering context with a +restricted rendering area. + +For example, the following will center a string in 30 columns, leaving +room for something to be placed next to it as the terminal width +changes: + +.. code:: haskell + + let w = hLimit 30 $ hCenter $ str "Hello, world!" + +The Attribute Map +----------------- + +The rendering context contains an attribute map (see `How Attributes +Work`_ and `appAttrMap: Managing Attributes`_) which is used to look up +attribute names from the drawing specification. The map originates from +``Brick.Main.appAttrMap`` and can be manipulated on a per-widget basis +using ``Brick.Widgets.Core.updateAttrMap``. + +The Active Border Style +----------------------- + +Widgets in the ``Brick.Widgets.Border`` module draw border characters +(horizontal, vertical, and boxes) between and around other widgets. To +ensure that widgets across your application share a consistent visual +style, border widgets consult the rendering context's *active border +style*, a value of type ``Brick.Widgets.Border.Style``, to get the +characters used to draw borders. + +The default border style is ``Brick.Widgets.Border.Style.unicode``. To +change border styles, use the ``Brick.Widgets.Core.withBorderStyle`` +combinator to wrap a widget and change the border style it uses when +rendering. For example, this will use the ``ascii`` border style instead +of ``unicode``: + +.. code:: haskell + + let w = withBorderStyle Brick.Widgets.Border.Style.ascii $ + Brick.Widgets.Border.border $ str "Hello, world!" + +How Attributes Work +=================== + +In addition to letting us map names to attributes, attribute maps +provide hierarchical attribute inheritance: a more specific attribute +derives any properties (e.g. background color) that it does not specify +from more general attributes in hierarchical relationship to it, letting +us customize only the parts of attributes that we want to change without +having to repeat ourselves. + +For example, this draws a string with a foreground color of ``white`` on +a background color of ``blue``: + +.. code:: haskell + + let w = withAttr specificAttr $ str "foobar" + generalAttr = attrName "general" + specificAttr = attrName "general" <> attrName "specific" + myMap = attrMap defAttr [ (generalAttr, bg blue) + , (specificAttr, fg white) + ] + +Functions ``Brick.Util.fg`` and ``Brick.Util.bg`` specify +partial attributes, and map lookups start with the desired name +(``general/specific`` in this case) and walk up the name hierarchy (to +``general``), merging partial attribute settings as they go, letting +already-specified attribute settings take precedence. Finally, any +attribute settings not specified by map lookups fall back to the map's +*default attribute*, specified above as ``Graphics.Vty.defAttr``. In +this way, if you want everything in your application to have a ``blue`` +background color, you only need to specify it *once*: in the attribute +map's default attribute. Any other attribute names can merely customize +the foreground color. + +In addition to using the attribute map provided by ``appAttrMap``, +the map can be customized on a per-widget basis by using the attribute +map combinators: + +* ``Brick.Widgets.Core.updateAttrMap`` +* ``Brick.Widgets.Core.forceAttr`` +* ``Brick.Widgets.Core.withDefAttr`` + +Viewports +========= + +A *viewport* is a scrollable window onto another widget. Viewports have +a *scrolling direction* of type ``Brick.Widgets.Core.ViewportType`` +which can be one of: + +* ``Horizontal``: the viewport can only scroll horizontally. +* ``Vertical``: the viewport can only scroll vertically. +* ``Both``: the viewport can scroll both horizontally and vertically. + +The ``Brick.Widgets.Core.viewport`` combinator takes another widget and +embeds it in a named viewport. We name the viewport so that we can +keep track of its scrolling state in the renderer, and so that you can +make scrolling requests. The viewport's name is its handle for these +operations (see `Scrolling Viewports in Event Handlers`_). *The viewport +name must be unique across your interface.* + +For example, the following puts a string in a horizontally-scrollable +viewport: + +.. code:: haskell + + let w = viewport (Name "myViewport") Horizontal $ str "Hello, world!" + +The above example is incomplete. A ``viewport`` specification means that +the widget in the viewport will be placed in a viewport window that is +``Greedy`` in both directions (see `Available Rendering Area`_). This +is suitable if we want the viewport size to be the size of the entire +terminal window, but if we want to embed this scrollable viewport +somewhere in our interface, we want to control its dimensions. To do so, +we use the limiting combinators (see `Limiting Rendering Area`_): + +.. code:: haskell + + let w = hLimit 5 $ + vLimit 1 $ + viewport (Name "myViewport") Horizontal $ str "Hello, world!" + +Now the example produces a scrollable window one row high and five +columns wide initially showing "Hello". The next two sections discuss +the two ways in which this viewport can be scrolled. + +Scrolling Viewports in Event Handlers +------------------------------------- + +The most direct way to scroll a viewport is to make *scrolling requests* +in the ``EventM`` event-handling monad. Scrolling requests ask the +render to update the state of a viewport the next time the user +interface is rendered. Those state updates will be made with respect to +the *previous* viewport state. This approach is the best approach to use +to scroll widgets that have no notion of a cursor. For cursor-based +scrolling, see `Scrolling Viewports With Visibility Requests`_. + +To make scrolling requests, we first create a +``Brick.Main.ViewportScroll`` from a viewport name with +``Brick.Main.viewportScroll``: + +.. code:: haskell + + let vp = viewportScroll (Name "myViewport") + +The ``ViewportScroll`` record type contains a number of scrolling +functions for making scrolling requests: + +.. code:: haskell + + hScrollPage :: Direction -> EventM () + hScrollBy :: Int -> EventM () + hScrollToBeginning :: EventM () + hScrollToEnd :: EventM () + vScrollPage :: Direction -> EventM () + vScrollBy :: Int -> EventM () + vScrollToBeginning :: EventM () + vScrollToEnd :: EventM () + +In each case the scrolling function scrolls the viewport by the +specified amount in the specified direction; functions prefixed with +``h`` scroll horizontally and functions prefixed with ``v`` scroll +vertically. + +Scrolling operations do nothing when they don't make sense for the +specified viewport; scrolling a ``Vertical`` viewport horizontally is a +no-op, for example. + +Using ``viewportScroll`` and the ``myViewport`` example given above, we +can write an event handler that scrolls the "Hello, world!" viewport one +column to the right: + +.. code:: haskell + + myHandler :: s -> e -> EventM (Next s) + myHandler s e = do + let vp = viewportScroll (Name "myViewport") + hScrollBy vp 1 + continue s + +Scrolling Viewports With Visibility Requests +-------------------------------------------- + +When we need to scroll widgets only when a cursor in the viewport leaves +the viewport's bounds, we need to use *visibility requests*. A +visibility request is a hint to the renderer that some element of a +widget inside a viewport should be made visible, i.e., that the viewport +should be scrolled to bring the requested element into view. + +To use a visibility request to make a widget in a viewport visible, we +simply wrap it with ``visible``: + +.. code:: haskell + + let w = viewport (Name "myViewport") Horizontal $ + (visible $ str "Hello," <+> (str " world!") + +This example requests that the "``myViewport``" viewport be scrolled so +that "Hello," is visible. We could extend this example with a value +in the application state indicating which word in our string should +be visible and then use that to change which string gets wrapped with +``visible``; this is the basis of cursor-based scrolling. + +Note that a visibility request does not change the state of a viewport +*if the requested widget is already visible*! This important detail is +what makes visibility requests so powerful, because they can be used to +capture various cursor-based scenarios: + +* The ``Brick.Widgets.Edit`` widget uses a visibility request to make its + 1x1 cursor position visible, thus making the text editing widget fully + scrollable *while being entirely scrolling-unaware*. +* The ``Brick.Widgets.List`` widget uses a visibility request to make + its selected item visible regardless of its size, which makes + the list widget both scrolling-unaware and also makes it support + variable-height items for free. + +Viewport Restrictions +--------------------- + +Viewports impose one restriction: a viewport that is scrollable in some +direction can only embed a widget that has a ``Fixed`` size in that +direction. This extends to ``Both`` type viewports: they can only embed +widgets that are ``Fixed`` in both directions. This restriction is +because when viewports embed a widget, they relax the rendering area +constraint in the rendering context, but doing so to a large enough +number for ``Greedy`` widgets would result in a widget that is too big +and not scrollable in a useful way. + +Violating this restriction will result in a runtime exception. + +Implementing Your Own Widgets +============================= + +``brick`` exposes all of the internals you need to implement your own +widgets. Those internals, together with ``Graphics.Vty``, can be used to +create widgets from the ground up. We start by writing a constructor +function: + +.. code:: haskell + + myWidget :: ... -> Widget + myWidget ... = + Widget Fixed Fixed $ do + ... + +We specify the horizontal and vertical growth policies of the widget +as ``Fixed`` in this example, although they should be specified +appropriately (see `How Widgets and Rendering Work`_). Lastly we specify +the *rendering function*, a function of type + +.. code:: haskell + + render :: RenderM Result + +which is a function returning a ``Brick.Widgets.Core.Result``: + +.. code:: haskell + + data Result = + Result { image :: Graphics.Vty.Image + , cursors :: [Brick.Types.CursorLocation] + , visibilityRequests :: [Brick.Widgets.Core.VisibilityRequest] + } + +The ``RenderM`` monad gives us access to the rendering context (see `How +Widgets and Rendering Work`_) via the ``Brick.Widgets.Core.getContext`` +function. The context type is: + +.. code:: haskell + + data Context = + Context { ctxAttrName :: AttrName + , availWidth :: Int + , availHeight :: Int + , ctxBorderStyle :: BorderStyle + , ctxAttrMap :: AttrMap + } + +and has `lens` fields exported as described in `Conventions`_. + +The job of the rendering function is to return a rendering result which, +at a minimum, means producing a ``vty`` ``Image``. In addition, if you +so choose, you can also return one or more cursor positions in the +``cursors`` field of the ``Result`` as well as visibility requests (see +`Viewports`_) in the ``visibilityRequests`` field. Returned visibility +requests and cursor positions should be relative to the upper-left +corner of your widget, ``Location (0, 0)``. When your widget is placed +in others, such as boxes, the ``Result`` data you returned will be +offset (as described in `Rendering Sub-Widgets`_) to result in correct +coordinates once the entire interface has been rendered. + +Using the Rendering Context +--------------------------- + +The most important fields of the context are the rendering area fields +``availWidth`` and ``availHeight``. These fields must be used to +determine how much space your widget has to render. + +To perform an attribute lookup in the attribute map for the context's +current attribute, use ``Brick.Widgets.Core.attrL``. + +For example, to build a widget that always fills the available width and +height with a fill character using the current attribute, we could +write: + +.. code:: haskell + + myFill :: Char -> Widget + myFill ch = + Widget Greedy Greedy $ do + ctx <- getContext + let a = ctx^.attrL + return $ Result (Graphics.Vty.charFill ch a (ctx^.availWidth) (ctx^.availHeight)) + [] [] + +Rendering Sub-Widgets +--------------------- + +If your custom widget wraps another, then in addition to rendering the +wrapped widget and augmenting its returned ``Result`` *it must also +translate the resulting cursor locations and visibility requests*. +This is vital to maintaining the correctness of cursor locations and +visbility locations as widget layout proceeds. To do so, use the +``Brick.Widgets.Core.addResultOffset`` function to offset the elements +of a ``Result`` by a specified amount. The amount depends on the nature +of the offset introduced by your wrapper widget's logic. + +Widgets are not required to respect the rendering context's width and +height restrictions. Widgets may be embedded in viewports or translated +so they must render without cropping to work in those scenarios. +However, widgets rendering other widgets *should* enforce the rendering +context's constraints to avoid using more space than is available. The +``Brick.Widgets.Core.cropToContext`` function is provided to make this +easy: + +.. code:: haskell + + let w = cropToContext someWidget + +Widgets wrapped with ``cropToContext`` can be safely embedded in other +widgets. If you don't want to crop in this way, you can use any of +``vty``'s cropping functions to operate on the ``Result`` image as +desired. + +.. _vty: https://github.com/coreyoconnor/vty +.. _Hackage: http://hackage.haskell.org/ +.. _lens: http://hackage.haskell.org/package/lens diff --git a/programs/AttrDemo.hs b/programs/AttrDemo.hs new file mode 100644 --- /dev/null +++ b/programs/AttrDemo.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Monoid +import Graphics.Vty + ( Event, Attr, white, blue, cyan, green, red, yellow + , black + ) + +import Brick.Main +import Brick.Widgets.Core + ( Widget + , (<=>) + , withAttr + , vBox + ) +import Brick.Util (on, fg) +import Brick.AttrMap (attrMap, AttrMap) + +ui :: Widget +ui = + vBox [ "This text uses the global default attribute." + , withAttr "foundFull" + "Specifying an attribute name means we look it up in the attribute tree." + , withAttr "foundFgOnly" + ("When we find a value, we merge it with its parent in the attribute" + <=> "name tree all the way to the root (the global default).") + , withAttr "missing" + "A missing attribute name just resumes the search at its parent." + , withAttr ("general" <> "specific") + "In this way we build complete attribute values by using an inheritance scheme." + , withAttr "foundFull" + "You can override everything ..." + , withAttr "foundFgOnly" + "... or only you want to change and inherit the rest." + , "Attribute names are assembled with the Monoid append operation to indicate" + , "hierarchy levels, e.g. \"window\" <> \"title\"." + ] + +globalDefault :: Attr +globalDefault = white `on` blue + +theMap :: AttrMap +theMap = attrMap globalDefault + [ ("foundFull", white `on` green) + , ("foundFgOnly", fg red) + , ("general", yellow `on` black) + , ("general" <> "specific", fg cyan) + ] + +app :: App () Event +app = + App { appDraw = const [ui] + , appHandleEvent = resizeOrQuit + , appStartEvent = return + , appAttrMap = const theMap + , appChooseCursor = neverShowCursor + , appLiftVtyEvent = id + } + +main :: IO () +main = defaultMain app () diff --git a/programs/BorderDemo.hs b/programs/BorderDemo.hs new file mode 100644 --- /dev/null +++ b/programs/BorderDemo.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Applicative ((<$>)) +import Data.Monoid +import qualified Data.Text as T +import qualified Graphics.Vty as V + +import qualified Brick.Main as M +import Brick.Util (fg, bg, on) +import qualified Brick.AttrMap as A +import Brick.Widgets.Core + ( Widget + , (<=>) + , (<+>) + , vLimit + , hLimit + , hBox + , updateAttrMap + , withBorderStyle + , txt + ) +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Border.Style as BS + +styles :: [(T.Text, BS.BorderStyle)] +styles = + [ ("ascii", BS.ascii) + , ("unicode", BS.unicode) + , ("unicode bold", BS.unicodeBold) + , ("unicode rounded", BS.unicodeRounded) + , ("custom", custom) + , ("from 'x'", BS.borderStyleFromChar 'x') + ] + +custom :: BS.BorderStyle +custom = + BS.BorderStyle { BS.bsCornerTL = '/' + , BS.bsCornerTR = '\\' + , BS.bsCornerBR = '/' + , BS.bsCornerBL = '\\' + , BS.bsIntersectFull = '.' + , BS.bsIntersectL = '.' + , BS.bsIntersectR = '.' + , BS.bsIntersectT = '.' + , BS.bsIntersectB = '.' + , BS.bsHorizontal = '*' + , BS.bsVertical = '!' + } + +borderDemos :: [Widget] +borderDemos = mkBorderDemo <$> styles + +mkBorderDemo :: (T.Text, BS.BorderStyle) -> Widget +mkBorderDemo (styleName, sty) = + withBorderStyle sty $ + B.borderWithLabel "label" $ + vLimit 5 $ + C.vCenter $ + txt $ " " <> styleName <> " style " + +borderMappings :: [(A.AttrName, V.Attr)] +borderMappings = + [ (B.borderAttr, V.yellow `on` V.black) + , (B.vBorderAttr, V.green `on` V.red) + , (B.hBorderAttr, V.white `on` V.green) + , (B.hBorderLabelAttr, fg V.blue) + , (B.tlCornerAttr, bg V.red) + , (B.trCornerAttr, bg V.blue) + , (B.blCornerAttr, bg V.yellow) + , (B.brCornerAttr, bg V.green) + ] + +colorDemo :: Widget +colorDemo = + updateAttrMap (A.applyAttrMappings borderMappings) $ + B.borderWithLabel "title" $ + hLimit 20 $ + vLimit 5 $ + C.center $ + "colors!" + +ui :: Widget +ui = + hBox borderDemos + <=> B.hBorder + <=> colorDemo + <=> B.hBorderWithLabel "horizontal border label" + <=> (C.center "Left of vertical border" + <+> B.vBorder + <+> C.center "Right of vertical border") + +main :: IO () +main = M.simpleMain ui diff --git a/programs/CustomEventDemo.hs b/programs/CustomEventDemo.hs new file mode 100644 --- /dev/null +++ b/programs/CustomEventDemo.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Lens (makeLenses, (^.), (&), (.~), (%~)) +import Control.Monad (void, forever) +import Control.Concurrent (newChan, writeChan, threadDelay, forkIO) +import Data.Default +import Data.Monoid +import qualified Graphics.Vty as V + +import Brick.Main + ( App(..) + , Next + , EventM + , showFirstCursor + , customMain + , continue + , halt + ) +import Brick.Widgets.Core + ( Widget + , (<=>) + , str + ) + +data St = + St { _stLastVtyEvent :: Maybe V.Event + , _stCounter :: Int + } + +makeLenses ''St + +data CustomEvent = VtyEvent V.Event + | Counter + +drawUI :: St -> [Widget] +drawUI st = [a] + where + a = (str $ "Last Vty event: " <> (show $ st^.stLastVtyEvent)) + <=> + (str $ "Counter value is: " <> (show $ st^.stCounter)) + +appEvent :: St -> CustomEvent -> EventM (Next St) +appEvent st e = + case e of + VtyEvent (V.EvKey V.KEsc []) -> halt st + VtyEvent ev -> continue $ st & stLastVtyEvent .~ (Just ev) + Counter -> continue $ st & stCounter %~ (+1) + +initialState :: St +initialState = + St { _stLastVtyEvent = Nothing + , _stCounter = 0 + } + +theApp :: App St CustomEvent +theApp = + App { appDraw = drawUI + , appChooseCursor = showFirstCursor + , appHandleEvent = appEvent + , appStartEvent = return + , appAttrMap = def + , appLiftVtyEvent = VtyEvent + } + +main :: IO () +main = do + chan <- newChan + + forkIO $ forever $ do + writeChan chan Counter + threadDelay 1000000 + + void $ customMain (V.mkVty def) chan theApp initialState diff --git a/programs/DialogDemo.hs b/programs/DialogDemo.hs new file mode 100644 --- /dev/null +++ b/programs/DialogDemo.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Monoid +import qualified Graphics.Vty as V + +import qualified Brick.Main as M +import Brick.Widgets.Core + ( Widget + , padAll + , str + ) +import qualified Brick.Widgets.Dialog as D +import qualified Brick.Widgets.Center as C +import qualified Brick.AttrMap as A +import Brick.Util (on, bg) +import qualified Brick.Types as T + +data Choice = Red | Blue | Green + deriving Show + +drawUI :: D.Dialog Choice -> [Widget] +drawUI d = [ui] + where + ui = D.renderDialog d $ C.hCenter $ padAll 1 $ str "This is the dialog body." + +appEvent :: D.Dialog Choice -> V.Event -> M.EventM (M.Next (D.Dialog Choice)) +appEvent d ev = + case ev of + V.EvKey V.KEsc [] -> M.halt d + V.EvKey V.KEnter [] -> M.halt d + _ -> M.continue $ T.handleEvent ev d + +initialState :: D.Dialog Choice +initialState = D.dialog "dialog" (Just "Title") (Just (0, choices)) 50 + where + choices = [ ("Red", Red) + , ("Blue", Blue) + , ("Green", Green) + ] + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (D.dialogAttr, V.white `on` V.blue) + , (D.buttonAttr, V.black `on` V.white) + , (D.buttonSelectedAttr, bg V.yellow) + ] + +theApp :: M.App (D.Dialog Choice) V.Event +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return + , M.appAttrMap = const theMap + , M.appLiftVtyEvent = id + } + +main :: IO () +main = do + d <- M.defaultMain theApp initialState + putStrLn $ "You chose: " <> show (D.dialogSelection d) diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs new file mode 100644 --- /dev/null +++ b/programs/EditDemo.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +module Main where + +import Control.Lens +import qualified Graphics.Vty as V + +import qualified Brick.Main as M +import qualified Brick.Types as T +import Brick.Widgets.Core + ( Widget + , (<+>) + , (<=>) + , hLimit + , vLimit + , str + ) +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Edit as E +import qualified Brick.AttrMap as A +import Brick.Util (on) + +data St = + St { _currentEditor :: T.Name + , _edit1 :: E.Editor + , _edit2 :: E.Editor + } + +makeLenses ''St + +firstEditor :: T.Name +firstEditor = "edit1" + +secondEditor :: T.Name +secondEditor = "edit2" + +switchEditors :: St -> St +switchEditors st = + let next = if st^.currentEditor == firstEditor + then secondEditor else firstEditor + in st & currentEditor .~ next + +currentEditorL :: St -> Lens' St E.Editor +currentEditorL st = + if st^.currentEditor == firstEditor + then edit1 + else edit2 + +drawUI :: St -> [Widget] +drawUI st = [ui] + where + ui = C.center $ ("Input 1 (unlimited): " <+> (hLimit 30 $ vLimit 5 $ E.renderEditor $ st^.edit1)) <=> + " " <=> + ("Input 2 (limited to 2 lines): " <+> (hLimit 30 $ E.renderEditor $ st^.edit2)) <=> + " " <=> + "Press Tab to switch between editors, Esc to quit." + +appEvent :: St -> V.Event -> M.EventM (M.Next St) +appEvent st ev = + case ev of + V.EvKey V.KEsc [] -> M.halt st + V.EvKey (V.KChar '\t') [] -> M.continue $ switchEditors st + _ -> M.continue $ st & currentEditorL st %~ T.handleEvent ev + +initialState :: St +initialState = + St firstEditor + (E.editor firstEditor (str . unlines) Nothing "") + (E.editor secondEditor (str . unlines) (Just 2) "") + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (E.editAttr, V.white `on` V.blue) + ] + +appCursor :: St -> [T.CursorLocation] -> Maybe T.CursorLocation +appCursor st = M.showCursorNamed (st^.currentEditor) + +theApp :: M.App St V.Event +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = appCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return + , M.appAttrMap = const theMap + , M.appLiftVtyEvent = id + } + +main :: IO () +main = do + st <- M.defaultMain theApp initialState + putStrLn "In input 1 you entered:\n" + putStrLn $ unlines $ E.getEditContents $ st^.edit1 + putStrLn "In input 2 you entered:\n" + putStrLn $ unlines $ E.getEditContents $ st^.edit2 diff --git a/programs/HelloWorldDemo.hs b/programs/HelloWorldDemo.hs new file mode 100644 --- /dev/null +++ b/programs/HelloWorldDemo.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Brick.Main (simpleMain) +import Brick.Widgets.Core (Widget) + +ui :: Widget +ui = "Hello, world!" + +main :: IO () +main = simpleMain ui diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs new file mode 100644 --- /dev/null +++ b/programs/LayerDemo.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Lens (makeLenses, (^.), (&), (%~)) +import Control.Monad (void) +import Data.Default +import qualified Graphics.Vty as V + +import qualified Brick.Types as T +import Brick.Types (rowL, columnL) +import qualified Brick.Main as M +import qualified Brick.Widgets.Border as B +import Brick.Widgets.Core + ( Widget + , translateBy + ) + +data St = + St { _topLayerLocation :: T.Location + , _bottomLayerLocation :: T.Location + } + +makeLenses ''St + +drawUi :: St -> [Widget] +drawUi st = + [ topLayer st + , bottomLayer st + ] + +topLayer :: St -> Widget +topLayer st = + translateBy (st^.topLayerLocation) $ + B.border "Top layer\n(Arrow keys move)" + +bottomLayer :: St -> Widget +bottomLayer st = + translateBy (st^.bottomLayerLocation) $ + B.border "Bottom layer\n(Ctrl-arrow keys move)" + +appEvent :: St -> V.Event -> M.EventM (M.Next St) +appEvent st (V.EvKey V.KDown []) = M.continue $ st & topLayerLocation.rowL %~ (+ 1) +appEvent st (V.EvKey V.KUp []) = M.continue $ st & topLayerLocation.rowL %~ (subtract 1) +appEvent st (V.EvKey V.KRight []) = M.continue $ st & topLayerLocation.columnL %~ (+ 1) +appEvent st (V.EvKey V.KLeft []) = M.continue $ st & topLayerLocation.columnL %~ (subtract 1) + +appEvent st (V.EvKey V.KDown [V.MCtrl]) = M.continue $ st & bottomLayerLocation.rowL %~ (+ 1) +appEvent st (V.EvKey V.KUp [V.MCtrl]) = M.continue $ st & bottomLayerLocation.rowL %~ (subtract 1) +appEvent st (V.EvKey V.KRight [V.MCtrl]) = M.continue $ st & bottomLayerLocation.columnL %~ (+ 1) +appEvent st (V.EvKey V.KLeft [V.MCtrl]) = M.continue $ st & bottomLayerLocation.columnL %~ (subtract 1) + +appEvent st (V.EvKey V.KEsc []) = M.halt st +appEvent st _ = M.continue st + +app :: M.App St V.Event +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = return + , M.appHandleEvent = appEvent + , M.appAttrMap = const def + , M.appLiftVtyEvent = id + , M.appChooseCursor = M.neverShowCursor + } + +main :: IO () +main = void $ M.defaultMain app $ St (T.Location (0, 0)) (T.Location (0, 0)) diff --git a/programs/ListDemo.hs b/programs/ListDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ListDemo.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Lens ((^.)) +import Control.Monad (void) +import Data.Monoid +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.AttrMap as A +import Brick.Widgets.Core + ( Widget + , (<+>) + , str + , vLimit + , hLimit + , vBox + , withAttr + ) +import Brick.Util (fg, on) + +drawUI :: L.List Int -> [Widget] +drawUI l = [ui] + where + label = "Item " <+> cur <+> " of " <+> total + cur = case l^.(L.listSelectedL) of + Nothing -> "-" + Just i -> str (show (i + 1)) + total = str $ show $ length $ l^.(L.listElementsL) + box = B.borderWithLabel label $ + hLimit 25 $ + vLimit 15 $ + L.renderList l + ui = C.vCenter $ vBox [ C.hCenter box + , " " + , C.hCenter "Press +/- to add/remove list elements." + , C.hCenter "Press Esc to exit." + ] + +appEvent :: L.List Int -> V.Event -> M.EventM (M.Next (L.List Int)) +appEvent l e = + case e of + V.EvKey (V.KChar '+') [] -> + let el = length $ l^.(L.listElementsL) + in M.continue $ L.listInsert el el l + + V.EvKey (V.KChar '-') [] -> + case l^.(L.listSelectedL) of + Nothing -> M.continue l + Just i -> M.continue $ L.listRemove i l + + V.EvKey V.KEsc [] -> M.halt l + + ev -> M.continue $ T.handleEvent ev l + +listDrawElement :: Bool -> Int -> Widget +listDrawElement sel i = + let selStr s = if sel + then withAttr customAttr (str $ "<" <> s <> ">") + else str s + in C.hCenter $ "Item " <+> (selStr $ show i) + +initialState :: L.List Int +initialState = L.list (T.Name "list") listDrawElement [0, 1, 2] + +customAttr :: A.AttrName +customAttr = L.listSelectedAttr <> "custom" + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (L.listAttr, V.white `on` V.blue) + , (L.listSelectedAttr, V.blue `on` V.white) + , (customAttr, fg V.cyan) + ] + +theApp :: M.App (L.List Int) V.Event +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return + , M.appAttrMap = const theMap + , M.appLiftVtyEvent = id + } + +main :: IO () +main = void $ M.defaultMain theApp initialState diff --git a/programs/MarkupDemo.hs b/programs/MarkupDemo.hs new file mode 100644 --- /dev/null +++ b/programs/MarkupDemo.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Monoid ((<>)) +import qualified Graphics.Vty as V + +import Brick.Main (App(..), defaultMain, resizeOrQuit, neverShowCursor) +import Brick.Widgets.Core + ( Widget + , (<=>) + ) +import Brick.Util (on, fg) +import Brick.Markup (markup, (@?)) +import Brick.AttrMap (attrMap, AttrMap) +import Data.Text.Markup ((@@)) + +ui :: Widget +ui = m1 <=> m2 + where + m1 = markup $ ("Hello" @@ fg V.blue) <> ", " <> ("world!" @@ fg V.red) + m2 = markup $ ("Hello" @? "keyword1") <> ", " <> ("world!" @? "keyword2") + +theMap :: AttrMap +theMap = attrMap V.defAttr + [ ("keyword1", fg V.magenta) + , ("keyword2", V.white `on` V.blue) + ] + +app :: App () V.Event +app = + App { appDraw = const [ui] + , appHandleEvent = resizeOrQuit + , appAttrMap = const theMap + , appStartEvent = return + , appChooseCursor = neverShowCursor + , appLiftVtyEvent = id + } + +main :: IO () +main = defaultMain app () diff --git a/programs/PaddingDemo.hs b/programs/PaddingDemo.hs new file mode 100644 --- /dev/null +++ b/programs/PaddingDemo.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Default +import qualified Graphics.Vty as V + +import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) +import Brick.Widgets.Core + ( Widget + , vBox + , hBox + , Padding(..) + , padAll + , padLeft + , padRight + , padTop + , padBottom + , padTopBottom + , padLeftRight + ) +import Brick.Widgets.Border as B +import Brick.Widgets.Center as C + +ui :: Widget +ui = + vBox [ hBox [ padLeft Max $ vCenter "Left-padded" + , B.vBorder + , padRight Max $ vCenter "Right-padded" + ] + , B.hBorder + , hBox [ padTop Max $ hCenter "Top-padded" + , B.vBorder + , padBottom Max $ hCenter "Bottom-padded" + ] + , B.hBorder + , hBox [ padLeftRight 2 "Padded by 2 on left/right" + , B.vBorder + , vBox [ padTopBottom 1 "Padded by 1 on top/bottom" + , B.hBorder + ] + ] + , B.hBorder + , padAll 2 "Padded by 2 on all sides" + ] + +app :: App () V.Event +app = + App { appDraw = const [ui] + , appHandleEvent = resizeOrQuit + , appStartEvent = return + , appAttrMap = const def + , appChooseCursor = neverShowCursor + , appLiftVtyEvent = id + } + +main :: IO () +main = defaultMain app () diff --git a/programs/SuspendAndResumeDemo.hs b/programs/SuspendAndResumeDemo.hs new file mode 100644 --- /dev/null +++ b/programs/SuspendAndResumeDemo.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Lens (makeLenses, (.~), (^.), (&)) +import Control.Monad (void) +import Data.Monoid +import Data.Default +import qualified Graphics.Vty as V + +import Brick.Main + ( App(..), neverShowCursor, defaultMain + , suspendAndResume, halt, continue + , EventM, Next + ) +import Brick.Widgets.Core + ( Widget + , vBox + , str + ) + +data St = + St { _stExternalInput :: String + } + +makeLenses ''St + +drawUI :: St -> [Widget] +drawUI st = [ui] + where + ui = vBox [ str $ "External input: \"" <> st^.stExternalInput <> "\"" + , "(Press Esc to quit or Space to ask for input)" + ] + +appEvent :: St -> V.Event -> EventM (Next St) +appEvent st e = + case e of + V.EvKey V.KEsc [] -> halt st + V.EvKey (V.KChar ' ') [] -> suspendAndResume $ do + putStrLn "Suspended. Please enter something and press enter to resume:" + s <- getLine + return $ st & stExternalInput .~ s + _ -> continue st + +initialState :: St +initialState = + St { _stExternalInput = "" + } + +theApp :: App St V.Event +theApp = + App { appDraw = drawUI + , appChooseCursor = neverShowCursor + , appHandleEvent = appEvent + , appStartEvent = return + , appAttrMap = const def + , appLiftVtyEvent = id + } + +main :: IO () +main = do + void $ defaultMain theApp initialState diff --git a/programs/ViewportScrollDemo.hs b/programs/ViewportScrollDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ViewportScrollDemo.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Applicative +import Control.Monad (void) +import Data.Monoid +import Data.Default +import qualified Graphics.Vty as V + +import qualified Brick.Types as T +import qualified Brick.Main as M +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Border as B +import Brick.Widgets.Core + ( Widget + , ViewportType(Horizontal, Vertical, Both) + , hLimit + , vLimit + , hBox + , vBox + , viewport + , str + ) + +vp1Name :: T.Name +vp1Name = "demo1" + +vp2Name :: T.Name +vp2Name = "demo2" + +vp3Name :: T.Name +vp3Name = "demo3" + +drawUi :: () -> [Widget] +drawUi = const [ui] + where + ui = C.center $ B.border $ hLimit 60 $ vLimit 21 $ + vBox [ pair, B.hBorder, singleton ] + singleton = viewport vp3Name Both $ + vBox $ "Press ctrl-arrow keys to scroll this viewport horizontally and vertically." + : (str <$> [ "Line " <> show i | i <- [2..25::Int] ]) + pair = hBox [ viewport vp1Name Vertical $ + vBox $ "Press up and down arrow keys" : + "to scroll this viewport." : + (str <$> [ "Line " <> (show i) | i <- [3..50::Int] ]) + , B.vBorder + , viewport vp2Name Horizontal + "Press left and right arrow keys to scroll this viewport." + ] + +vp1Scroll :: M.ViewportScroll +vp1Scroll = M.viewportScroll vp1Name + +vp2Scroll :: M.ViewportScroll +vp2Scroll = M.viewportScroll vp2Name + +vp3Scroll :: M.ViewportScroll +vp3Scroll = M.viewportScroll vp3Name + +appEvent :: () -> V.Event -> M.EventM (M.Next ()) +appEvent _ (V.EvKey V.KDown [V.MCtrl]) = M.vScrollBy vp3Scroll 1 >> M.continue () +appEvent _ (V.EvKey V.KUp [V.MCtrl]) = M.vScrollBy vp3Scroll (-1) >> M.continue () +appEvent _ (V.EvKey V.KRight [V.MCtrl]) = M.hScrollBy vp3Scroll 1 >> M.continue () +appEvent _ (V.EvKey V.KLeft [V.MCtrl]) = M.hScrollBy vp3Scroll (-1) >> M.continue () +appEvent _ (V.EvKey V.KDown []) = M.vScrollBy vp1Scroll 1 >> M.continue () +appEvent _ (V.EvKey V.KUp []) = M.vScrollBy vp1Scroll (-1) >> M.continue () +appEvent _ (V.EvKey V.KRight []) = M.hScrollBy vp2Scroll 1 >> M.continue () +appEvent _ (V.EvKey V.KLeft []) = M.hScrollBy vp2Scroll (-1) >> M.continue () +appEvent _ (V.EvKey V.KEsc []) = M.halt () +appEvent _ _ = M.continue () + +app :: M.App () V.Event +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = return + , M.appHandleEvent = appEvent + , M.appAttrMap = const def + , M.appLiftVtyEvent = id + , M.appChooseCursor = M.neverShowCursor + } + +main :: IO () +main = void $ M.defaultMain app () diff --git a/programs/VisibilityDemo.hs b/programs/VisibilityDemo.hs new file mode 100644 --- /dev/null +++ b/programs/VisibilityDemo.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Monad (void) +import Control.Lens +import Data.Monoid +import qualified Graphics.Vty as V + +import qualified Brick.Types as T +import qualified Brick.Main as M +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Border as B +import Brick.AttrMap (AttrMap, AttrName, attrMap) +import Brick.Util (on) +import Brick.Widgets.Core + ( Widget + , ViewportType(Horizontal, Vertical, Both) + , withAttr + , hLimit + , vLimit + , hBox + , vBox + , viewport + , str + , visible + ) + +data St = + St { _vp1Index :: Int + , _vp2Index :: Int + , _vp3Index :: (Int, Int) + } + +makeLenses ''St + +vp1Name :: T.Name +vp1Name = "demo1" + +vp1Size :: Int +vp1Size = 15 + +vp2Name :: T.Name +vp2Name = "demo2" + +vp2Size :: Int +vp2Size = 15 + +vp3Name :: T.Name +vp3Name = "demo3" + +vp3Size :: (Int, Int) +vp3Size = (25, 25) + +selectedAttr :: AttrName +selectedAttr = "selected" + +drawUi :: St -> [Widget] +drawUi st = [ui] + where + ui = C.center $ hLimit 60 $ vLimit 30 $ + vBox [ B.border $ vBox [ pair, B.hBorder, singleton ] + , str $ "- Up/down arrow keys scroll the top-left viewport\n" <> + "- Left/right arrow keys scroll the top-right viewport\n" <> + "- Ctrl-arrow keys move the bottom viewport" + ] + singleton = viewport vp3Name Both $ + vBox $ do + i <- [1..vp3Size^._1] + let row = do + j <- [1..vp3Size^._2] + let mkItem = if (i, j) == st^.vp3Index + then withAttr selectedAttr . visible + else id + return $ mkItem $ str $ "Item " <> show (i, j) <> " " + return $ hBox row + + pair = hBox [ vp1, B.vBorder, vp2 ] + vp1 = viewport vp1Name Vertical $ + vBox $ do + i <- [1..vp1Size] + let mkItem = if i == st^.vp1Index + then withAttr selectedAttr . visible + else id + return $ mkItem $ str $ "Item " <> show i + vp2 = viewport vp2Name Horizontal $ + hBox $ do + i <- [1..vp2Size] + let mkItem = if i == st^.vp2Index + then withAttr selectedAttr . visible + else id + return $ mkItem $ str $ "Item " <> show i <> " " + +vp1Scroll :: M.ViewportScroll +vp1Scroll = M.viewportScroll vp1Name + +vp2Scroll :: M.ViewportScroll +vp2Scroll = M.viewportScroll vp2Name + +vp3Scroll :: M.ViewportScroll +vp3Scroll = M.viewportScroll vp3Name + +appEvent :: St -> V.Event -> M.EventM (M.Next St) +appEvent st (V.EvKey V.KDown [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ min (vp3Size^._1) . (+ 1) +appEvent st (V.EvKey V.KUp [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ max 1 . subtract 1 +appEvent st (V.EvKey V.KRight [V.MCtrl]) = M.continue $ st & vp3Index._2 %~ min (vp3Size^._1) . (+ 1) +appEvent st (V.EvKey V.KLeft [V.MCtrl]) = M.continue $ st & vp3Index._2 %~ max 1 . subtract 1 +appEvent st (V.EvKey V.KDown []) = M.continue $ st & vp1Index %~ min vp1Size . (+ 1) +appEvent st (V.EvKey V.KUp []) = M.continue $ st & vp1Index %~ max 1 . subtract 1 +appEvent st (V.EvKey V.KRight []) = M.continue $ st & vp2Index %~ min vp2Size . (+ 1) +appEvent st (V.EvKey V.KLeft []) = M.continue $ st & vp2Index %~ max 1 . subtract 1 +appEvent st (V.EvKey V.KEsc []) = M.halt st +appEvent st _ = M.continue st + +theMap :: AttrMap +theMap = attrMap V.defAttr + [ (selectedAttr, V.black `on` V.yellow) + ] + +app :: M.App St V.Event +app = + M.App { M.appDraw = drawUi + , M.appStartEvent = return + , M.appHandleEvent = appEvent + , M.appAttrMap = const theMap + , M.appLiftVtyEvent = id + , M.appChooseCursor = M.neverShowCursor + } + +initialState :: St +initialState = St 1 1 (1, 1) + +main :: IO () +main = void $ M.defaultMain app initialState diff --git a/src/Brick/AttrMap.hs b/src/Brick/AttrMap.hs new file mode 100644 --- /dev/null +++ b/src/Brick/AttrMap.hs @@ -0,0 +1,168 @@ +-- | 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 +-- specify partial attributes. Hierarchical names are created with 'mappend': +-- +-- @ +-- let n = attrName "parent" <> attrName "child" +-- @ +-- +-- 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 +-- 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 +-- attributes in the same hierarchy. This allows more modularity and +-- less repetition in specifying how elements of your user interface +-- take on different attributes. +module Brick.AttrMap + ( AttrMap + , AttrName + -- * Construction + , attrMap + , forceAttrMap + , attrName + -- * Finding attributes from names + , attrMapLookup + -- * Manipulating attribute maps + , setDefault + , applyAttrMappings + , mergeWithDefault + ) +where + +import Control.Applicative ((<$>)) +import qualified Data.Map as M +import Data.Monoid +import Data.Maybe (catMaybes) +import Data.List (inits) +import Data.String (IsString(..)) +import Data.Default (Default(..)) + +import Graphics.Vty (Attr(..), MaybeDefault(..)) + +-- | An attribute name. Attribute names are hierarchical; use 'mappend' +-- ('<>') to assemble them. Hierachy in an attribute name is used to +-- represent increasing levels of specificity in referring to the +-- attribute you want to use for a visual element, with names to the +-- left being general and names to the right being more specific. For +-- example: +-- +-- @ +-- "window" <> "border" +-- "window" <> "title" +-- "header" <> "clock" <> "seconds" +-- @ +data AttrName = AttrName [String] + deriving (Show, Eq, Ord) + +instance Default AttrName where + def = mempty + +instance Monoid AttrName where + mempty = AttrName [] + mappend (AttrName as) (AttrName bs) = AttrName $ as `mappend` bs + +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 + deriving Show + +instance Default AttrMap where + def = AttrMap def mempty + +-- | Create an attribute name from a string. +attrName :: String -> AttrName +attrName = AttrName . (:[]) + +-- | Create an attribute map. +attrMap :: Attr + -- ^ The map's default attribute to be returned when a name + -- lookup fails, and the attribute that will be merged with + -- successful lookups. + -> [(AttrName, Attr)] + -- ^ The map's initial contents. + -> AttrMap +attrMap theDefault pairs = AttrMap theDefault (M.fromList pairs) + +-- | Create an attribute map in which all lookups map to the same +-- attribute. +forceAttrMap :: Attr -> AttrMap +forceAttrMap = ForceAttr + +-- | 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 +-- the one specified here. Otherwise the attribute given here is merged +-- with the attribute map's default attribute in that any aspect of the +-- specified attribute that is not provided falls back to the map +-- default. For example, +-- +-- @ +-- mergeWithDefault (fg blue) $ attrMap (bg red) [] +-- @ +-- +-- returns +-- +-- @ +-- blue \`on\` red +-- @ +mergeWithDefault :: Attr -> AttrMap -> Attr +mergeWithDefault _ (ForceAttr a) = a +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. +-- +-- 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 -> AttrMap -> Attr +attrMapLookup _ (ForceAttr a) = a +attrMapLookup (AttrName []) (AttrMap theDefault _) = theDefault +attrMapLookup (AttrName ns) (AttrMap theDefault m) = + let results = catMaybes $ (\n -> M.lookup n m) <$> (AttrName <$> (inits ns)) + in foldl combineAttrs theDefault results + +-- | Set the default attribute value in an attribute map. +setDefault :: Attr -> AttrMap -> AttrMap +setDefault _ (ForceAttr a) = ForceAttr a +setDefault newDefault (AttrMap _ m) = AttrMap newDefault m + +combineAttrs :: Attr -> Attr -> Attr +combineAttrs (Attr s1 f1 b1) (Attr s2 f2 b2) = + Attr (s1 `combineMDs` s2) + (f1 `combineMDs` f2) + (b1 `combineMDs` b2) + +combineMDs :: MaybeDefault a -> MaybeDefault a -> MaybeDefault a +combineMDs _ (SetTo v) = SetTo v +combineMDs (SetTo v) _ = SetTo v +combineMDs _ 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) diff --git a/src/Brick/Focus.hs b/src/Brick/Focus.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Focus.hs @@ -0,0 +1,68 @@ +-- | This module provides a type and functions for handling focus rings +-- of widgets. Note that this interface is merely provided for managing +-- the focus state for a sequence of widget names; it does not do +-- anything beyond keep track of that. +-- +-- This interface is experimental. +module Brick.Focus + ( FocusRing + , focusRing + , focusNext + , focusPrev + , focusGetCurrent + , focusRingCursor + ) +where + +import Control.Lens ((^.)) +import Data.Maybe (listToMaybe) + +import Brick.Types + +-- | A focus ring containing a sequence of widget names to focus and a +-- currently-focused widget name. +data FocusRing = FocusRingEmpty + | FocusRingNonempty ![Name] !Int + +-- | Construct a focus ring from the list of names. +focusRing :: [Name] -> FocusRing +focusRing [] = FocusRingEmpty +focusRing names = FocusRingNonempty names 0 + +-- | Advance focus to the next widget in the ring. +focusNext :: FocusRing -> FocusRing +focusNext FocusRingEmpty = FocusRingEmpty +focusNext (FocusRingNonempty ns i) = FocusRingNonempty ns i' + where + i' = (i + 1) `mod` (length ns) + +-- | Advance focus to the previous widget in the ring. +focusPrev :: FocusRing -> FocusRing +focusPrev FocusRingEmpty = FocusRingEmpty +focusPrev (FocusRingNonempty ns i) = FocusRingNonempty ns i' + where + i' = (i + (length ns) - 1) `mod` (length ns) + +-- | Get the currently-focused widget name from the ring. If the ring is +-- emtpy, return 'Nothing'. +focusGetCurrent :: FocusRing -> Maybe Name +focusGetCurrent FocusRingEmpty = Nothing +focusGetCurrent (FocusRingNonempty ns i) = Just $ ns !! i + +-- | Cursor selection convenience function for use as an +-- 'Brick.Main.appChooseCursor' value. +focusRingCursor :: (a -> FocusRing) + -- ^ The function used to get the focus ring out of your + -- application state. + -> a + -- ^ Your application state. + -> [CursorLocation] + -- ^ The list of available cursor positions. + -> Maybe CursorLocation + -- ^ The cursor position, if any, that matches the name + -- currently focused by the 'FocusRing'. +focusRingCursor getRing st ls = + listToMaybe $ filter isCurrent ls + where + isCurrent cl = cl^.cursorLocationNameL == + (focusGetCurrent $ getRing st) diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Main.hs @@ -0,0 +1,305 @@ +module Brick.Main + ( App(..) + , defaultMain + , customMain + , simpleMain + , resizeOrQuit + + -- * Event handler functions + , EventM + , Next + , continue + , halt + , suspendAndResume + + -- ** Viewport scrolling + , viewportScroll + , ViewportScroll + , vScrollBy + , vScrollPage + , vScrollToBeginning + , vScrollToEnd + , hScrollBy + , hScrollPage + , hScrollToBeginning + , hScrollToEnd + + -- * Cursor management functions + , neverShowCursor + , showFirstCursor + , showCursorNamed + ) +where + +import Control.Exception (finally) +import Control.Lens ((^.)) +import Control.Monad (forever) +import Control.Monad.Trans.State +import Control.Concurrent (forkIO, Chan, newChan, readChan, writeChan, killThread) +import Data.Default +import Data.Maybe (listToMaybe) +import qualified Data.Map as M +import Graphics.Vty + ( Vty + , Picture(..) + , Cursor(..) + , Event(..) + , update + , outputIface + , displayBounds + , shutdown + , nextEvent + , mkVty + ) + +import Brick.Widgets.Core (Widget) +import Brick.Widgets.Internal (renderFinal, RenderState(..), ScrollRequest(..), Direction(..)) +import Brick.Types (rowL, columnL, CursorLocation(..), cursorLocationNameL, Name(..)) +import Brick.AttrMap + +-- | The type of actions to take in an event handler. +data Next a = Continue a + | SuspendAndResume (IO a) + | Halt a + +-- | The library application abstraction. Your application's operations +-- are represented here and passed to one of the various main functions +-- in this module. An application is in terms of an application state +-- type 's' and an application event type 'e'. In the simplest case 'e' is +-- vty's 'Event' type, but you may define your own event type, permitted +-- that it has a constructor for wrapping Vty events, so that Vty events +-- can be handled by your event loop. +data App s e = + App { appDraw :: s -> [Widget] + -- ^ This function turns your application state into a list of + -- widget layers. The layers are listed topmost first. + , appChooseCursor :: s -> [CursorLocation] -> Maybe CursorLocation + -- ^ This function chooses which of the zero or more cursor + -- locations reported by the rendering process should be + -- selected as the one to use to place the cursor. If this + -- returns 'Nothing', no cursor is placed. The rationale here + -- is that many widgets may request a cursor placement but your + -- application state is what you probably want to use to decide + -- which one wins. + , appHandleEvent :: s -> e -> EventM (Next s) + -- ^ This function takes the current application state and an + -- event and returns an action to be taken and a corresponding + -- transformed application state. Possible options are + -- 'continue', 'suspendAndResume', and 'halt'. + , appStartEvent :: s -> EventM s + -- ^ This function gets called once just prior to the first + -- drawing of your application. Here is where you can make + -- initial scrolling requests, for example. + , appAttrMap :: s -> AttrMap + -- ^ The attribute map that should be used during rendering. + , appLiftVtyEvent :: Event -> e + -- ^ The event constructor to use to wrap Vty events in your own + -- event type. For example, if the application's event type is + -- 'Event', this is just 'id'. + } + +-- | The monad in which event handlers run. +type EventM a = StateT EventState IO a + +type EventState = [(Name, ScrollRequest)] + +-- | The default main entry point which takes an application and an +-- initial state and returns the final state returned by a 'halt' +-- operation. +defaultMain :: App s Event + -- ^ The application. + -> s + -- ^ The initial application state. + -> IO s +defaultMain app st = do + chan <- newChan + customMain (mkVty def) chan app st + +-- | A simple main entry point which takes a widget and renders it. This +-- event loop terminates when the user presses any key, but terminal +-- resize events cause redraws. +simpleMain :: Widget + -- ^ The widget to draw. + -> IO () +simpleMain w = + let app = App { appDraw = const [w] + , appHandleEvent = resizeOrQuit + , appStartEvent = return + , appAttrMap = def + , appLiftVtyEvent = id + , appChooseCursor = neverShowCursor + } + in defaultMain app () + +-- | An event-handling function which continues execution of the event +-- loop only when resize events occur; all other types of events trigger +-- a halt. This is a convenience function useful as an 'appHandleEvent' +-- value for simple applications using the 'Event' type that do not need +-- to get more sophisticated user input. +resizeOrQuit :: s -> Event -> EventM (Next s) +resizeOrQuit s (EvResize _ _) = continue s +resizeOrQuit s _ = halt s + +data InternalNext a = InternalSuspendAndResume RenderState (IO a) + | InternalHalt a + +runWithNewVty :: IO Vty -> Chan e -> App s e -> RenderState -> s -> IO (InternalNext s) +runWithNewVty buildVty chan app initialRS initialSt = do + withVty buildVty $ \vty -> do + pid <- forkIO $ supplyVtyEvents vty (appLiftVtyEvent app) chan + let runInner rs st = do + (result, newRS) <- runVty vty chan app st rs + case result of + SuspendAndResume act -> do + killThread pid + return $ InternalSuspendAndResume newRS act + Halt s -> do + killThread pid + return $ InternalHalt s + Continue s -> runInner newRS s + runInner initialRS initialSt + +-- | The custom event loop entry point to use when the simpler ones +-- don't permit enough control. +customMain :: IO Vty + -- ^ An IO action to build a Vty handle. This is used to + -- build a Vty handle whenever the event loop begins or is + -- resumed after suspension. + -> Chan e + -- ^ An event channel for sending custom events to the event + -- loop (you write to this channel, the event loop reads from + -- it). + -> App s e + -- ^ The application. + -> s + -- ^ The initial application state. + -> IO s +customMain buildVty chan app initialAppState = do + let run rs st = do + result <- runWithNewVty buildVty chan app rs st + case result of + InternalHalt s -> return s + InternalSuspendAndResume newRS action -> do + newAppState <- action + run newRS newAppState + + (st, initialScrollReqs) <- runStateT (appStartEvent app initialAppState) [] + let initialRS = RS M.empty initialScrollReqs + run initialRS st + +supplyVtyEvents :: Vty -> (Event -> e) -> Chan e -> IO () +supplyVtyEvents vty mkEvent chan = + forever $ do + e <- nextEvent vty + writeChan chan $ mkEvent e + +runVty :: Vty -> Chan e -> App s e -> s -> RenderState -> IO (Next s, RenderState) +runVty vty chan app appState rs = do + firstRS <- renderApp vty app appState rs + e <- readChan chan + (next, scrollReqs) <- runStateT (appHandleEvent app appState e) [] + return (next, firstRS { scrollRequests = scrollReqs }) + +withVty :: IO Vty -> (Vty -> IO a) -> IO a +withVty buildVty useVty = do + vty <- buildVty + useVty vty `finally` shutdown vty + +renderApp :: Vty -> App s e -> s -> RenderState -> IO RenderState +renderApp vty app appState rs = do + sz <- displayBounds $ outputIface vty + let (newRS, pic, theCursor) = renderFinal (appAttrMap app appState) + (appDraw app appState) + sz + (appChooseCursor app appState) + rs + picWithCursor = case theCursor of + Nothing -> pic { picCursor = NoCursor } + Just loc -> pic { picCursor = Cursor (loc^.columnL) (loc^.rowL) } + + update vty picWithCursor + + return newRS + +-- | Ignore all requested cursor positions returned by the rendering +-- process. This is a convenience function useful as an +-- 'appChooseCursor' value when a simple application has no need to +-- position the cursor. +neverShowCursor :: s -> [CursorLocation] -> Maybe CursorLocation +neverShowCursor = const $ const Nothing + +-- | Always show the first cursor, if any, returned by the rendering +-- process. This is a convenience function useful as an +-- 'appChooseCursor' value when a simple program has zero or more +-- widgets that advertise a cursor position. +showFirstCursor :: s -> [CursorLocation] -> Maybe CursorLocation +showFirstCursor = const listToMaybe + +-- | Show the cursor with the specified name, if such a cursor location +-- has been reported. +showCursorNamed :: Name -> [CursorLocation] -> Maybe CursorLocation +showCursorNamed name locs = + let matches loc = loc^.cursorLocationNameL == Just name + in listToMaybe $ filter matches locs + +-- | A viewport scrolling handle for managing the scroll state of +-- viewports. +data ViewportScroll = + ViewportScroll { viewportName :: Name + -- ^ The name of the viewport to be controlled by + -- this scrolling handle. + , hScrollPage :: Direction -> EventM () + -- ^ Scroll the viewport horizontally by one page in + -- the specified direction. + , hScrollBy :: Int -> EventM () + -- ^ Scroll the viewport horizontally by the + -- specified number of rows or columns depending on + -- the orientation of the viewport. + , hScrollToBeginning :: EventM () + -- ^ Scroll horizontally to the beginning of the + -- viewport. + , hScrollToEnd :: EventM () + -- ^ Scroll horizontally to the end of the viewport. + , vScrollPage :: Direction -> EventM () + -- ^ Scroll the viewport vertically by one page in + -- the specified direction. + , vScrollBy :: Int -> EventM () + -- ^ Scroll the viewport vertically by the specified + -- number of rows or columns depending on the + -- orientation of the viewport. + , vScrollToBeginning :: EventM () + -- ^ Scroll vertically to the beginning of the viewport. + , vScrollToEnd :: EventM () + -- ^ Scroll vertically to the end of the viewport. + } + +-- | Build a viewport scroller for the viewport with the specified name. +viewportScroll :: Name -> ViewportScroll +viewportScroll n = + ViewportScroll { viewportName = n + , hScrollPage = \dir -> modify ((n, HScrollPage dir) :) + , hScrollBy = \i -> modify ((n, HScrollBy i) :) + , hScrollToBeginning = modify ((n, HScrollToBeginning) :) + , hScrollToEnd = modify ((n, HScrollToEnd) :) + , vScrollPage = \dir -> modify ((n, HScrollPage dir) :) + , vScrollBy = \i -> modify ((n, VScrollBy i) :) + , vScrollToBeginning = modify ((n, VScrollToBeginning) :) + , vScrollToEnd = modify ((n, VScrollToEnd) :) + } + +-- | Continue running the event loop with the specified application +-- state. +continue :: s -> EventM (Next s) +continue = return . Continue + +-- | Halt the event loop and return the specified application state as +-- the final state value. +halt :: s -> EventM (Next s) +halt = return . Halt + +-- | Suspend the event loop, save the terminal state, and run the +-- specified action. When it returns an application state value, restore +-- the terminal state, redraw the application from the new state, and +-- resume the event loop. +suspendAndResume :: IO s -> EventM (Next s) +suspendAndResume = return . SuspendAndResume diff --git a/src/Brick/Markup.hs b/src/Brick/Markup.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Markup.hs @@ -0,0 +1,54 @@ +-- | This module provides an API for turning "markup" values into +-- widgets. This module uses the Data.Text.Markup interface in this +-- package to assign attributes to substrings in a text string; to +-- manipulate markup using (for example) syntax highlighters, see that +-- module. +module Brick.Markup + ( Markup + , markup + , (@?) + , GetAttr(..) + ) +where + +import Control.Lens ((.~), (&), (^.)) +import Control.Monad (forM) +import qualified Data.Text as T +import Data.Text.Markup +import Data.Default (def) + +import Graphics.Vty (Attr, horizCat, string) + +import Brick.Widgets.Core +import Brick.AttrMap + +-- | A type class for types that provide access to an attribute in the +-- rendering monad. You probably won't need to instance this. +class GetAttr a where + -- | Where to get the attribute for this attribute metadata. + getAttr :: a -> RenderM Attr + +instance GetAttr Attr where + getAttr a = do + c <- getContext + return $ mergeWithDefault a (c^.ctxAttrMapL) + +instance GetAttr AttrName where + getAttr = lookupAttrName + +-- | Build a piece of markup from text with an assigned attribute name. +-- When the markup is rendered, the attribute name will be looked up in +-- the rendering context's 'AttrMap' to determine the attribute to use +-- for this piece of text. +(@?) :: T.Text -> AttrName -> Markup AttrName +(@?) = (@@) + +-- | Build a widget from markup. +markup :: (Eq a, GetAttr a) => Markup a -> Widget +markup m = + Widget Fixed Fixed $ do + let pairs = markupToList m + imgs <- forM pairs $ \(t, aSrc) -> do + a <- getAttr aSrc + return $ string a $ T.unpack t + return $ def & imageL .~ horizCat imgs diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Types.hs @@ -0,0 +1,89 @@ +-- | Basic types used by this library. +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Brick.Types + ( Location(..) + , locL + , TerminalLocation(..) + , CursorLocation(..) + , cursorLocationL + , cursorLocationNameL + , HandleEvent(..) + , Name(..) + , suffixLenses + ) +where + +import Control.Lens +import Data.String +import Data.Monoid (Monoid(..)) +import Graphics.Vty (Event) + +import Brick.Types.TH + +-- | A terminal screen location. +data Location = Location { loc :: (Int, Int) + -- ^ (Column, Row) + } + deriving Show + +suffixLenses ''Location + +instance Field1 Location Location Int Int where + _1 = locL._1 + +instance Field2 Location Location Int Int where + _2 = locL._2 + +-- | The class of types that behave like terminal locations. +class TerminalLocation a where + -- | Get the column out of the value + columnL :: Lens' a Int + column :: a -> Int + -- | Get the row out of the value + rowL :: Lens' a Int + row :: a -> Int + +instance TerminalLocation Location where + columnL = _1 + column (Location t) = fst t + rowL = _2 + row (Location t) = snd t + +-- | Names of things. Used to name cursor locations, widgets, and +-- viewports. +newtype Name = Name String + deriving (Eq, Show, Ord) + +instance IsString Name where + fromString = Name + +-- | The origin (upper-left corner). +origin :: Location +origin = Location (0, 0) + +instance Monoid Location where + mempty = origin + mappend (Location (w1, h1)) (Location (w2, h2)) = Location (w1+w2, h1+h2) + +-- | A cursor location. These are returned by the rendering process. +data CursorLocation = + CursorLocation { cursorLocation :: !Location + -- ^ The location + , cursorLocationName :: !(Maybe Name) + -- ^ The name of the widget associated with the location + } + deriving Show + +suffixLenses ''CursorLocation + +instance TerminalLocation CursorLocation where + columnL = cursorLocationL._1 + column = column . cursorLocation + rowL = cursorLocationL._2 + row = row . cursorLocation + +-- | The class of types that provide some basic event-handling. +class HandleEvent a where + -- | Handle a Vty event + handleEvent :: Event -> a -> a diff --git a/src/Brick/Types/TH.hs b/src/Brick/Types/TH.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Types/TH.hs @@ -0,0 +1,18 @@ +module Brick.Types.TH + ( suffixLenses + ) +where + +import qualified Language.Haskell.TH.Syntax as TH +import qualified Language.Haskell.TH.Lib as TH + +import Control.Lens (DefName(..), 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 +-- 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"]) diff --git a/src/Brick/Util.hs b/src/Brick/Util.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Util.hs @@ -0,0 +1,59 @@ +-- | Utility functions. +module Brick.Util + ( clamp + , on + , fg + , bg + , clOffset + ) +where + +import Control.Lens ((&), (%~)) +import Data.Monoid ((<>)) +import Graphics.Vty + +import Brick.Types (Location(..), CursorLocation(..), cursorLocationL) + +-- | Given a minimum value and a maximum value, clamp a value to that +-- range (values less than the minimum map to the minimum and values +-- greater than the maximum map to the maximum). +-- +-- >>> clamp 1 10 11 +-- 10 +-- >>> clamp 1 10 2 +-- 2 +-- >>> clamp 5 10 1 +-- 5 +clamp :: (Ord a) + => a + -- ^ The minimum value + -> a + -- ^ The maximum value + -> a + -- ^ The value to clamp + -> a +clamp mn mx val = max mn (min val mx) + +-- | Build an attribute from a foreground color and a background color. +-- Intended to be used infix. +on :: Color + -- ^ The foreground color + -> Color + -- ^ The background color + -> Attr +on f b = defAttr `withForeColor` f + `withBackColor` b + +-- | Create an attribute from the specified foreground color (the +-- background color is the "default"). +fg :: Color -> Attr +fg = (defAttr `withForeColor`) + +-- | Create an attribute from the specified background color (the +-- background color is the "default"). +bg :: Color -> Attr +bg = (defAttr `withBackColor`) + +-- | Add a 'Location' offset to the specified 'CursorLocation'. +clOffset :: CursorLocation -> Location -> CursorLocation +clOffset cl off = cl & cursorLocationL %~ (<> off) diff --git a/src/Brick/Widgets/Border.hs b/src/Brick/Widgets/Border.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Border.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides border widgets: vertical borders, horizontal +-- borders, and a box border wrapper widget. All functions in this +-- module use the rendering context's active 'BorderStyle'; to change +-- the 'BorderStyle', use 'withBorderStyle'. +module Brick.Widgets.Border + ( -- * Border wrapper + border + , borderWithLabel + + -- * Horizontal border + , hBorder + , hBorderWithLabel + + -- * Vertical border + , vBorder + + -- * Drawing single border elements + , borderElem + + -- * Border attribute names + , borderAttr + , vBorderAttr + , hBorderAttr + , hBorderLabelAttr + , tlCornerAttr + , trCornerAttr + , blCornerAttr + , brCornerAttr + ) +where + +import Control.Applicative ((<$>)) +import Control.Lens ((^.), to) +import Data.Monoid ((<>)) +import Graphics.Vty (imageHeight, imageWidth) + +import Brick.AttrMap +import Brick.Widgets.Core +import Brick.Widgets.Center (hCenterWith) +import Brick.Widgets.Border.Style (BorderStyle(..)) + +-- | The top-level border attribute name. +borderAttr :: AttrName +borderAttr = "border" + +-- | The vertical border attribute name. +vBorderAttr :: AttrName +vBorderAttr = borderAttr <> "vertical" + +-- | The horizontal border attribute name. +hBorderAttr :: AttrName +hBorderAttr = borderAttr <> "horizontal" + +-- | The attribute used for horizontal border labels. +hBorderLabelAttr :: AttrName +hBorderLabelAttr = hBorderAttr <> "label" + +-- | The attribute used for border box top-left corners. +tlCornerAttr :: AttrName +tlCornerAttr = borderAttr <> "corner" <> "tl" + +-- | The attribute used for border box top-right corners. +trCornerAttr :: AttrName +trCornerAttr = borderAttr <> "corner" <> "tr" + +-- | The attribute used for border box bottom-left corners. +blCornerAttr :: AttrName +blCornerAttr = borderAttr <> "corner" <> "bl" + +-- | The attribute used for border box bottom-right corners. +brCornerAttr :: AttrName +brCornerAttr = borderAttr <> "corner" <> "br" + +-- | Draw the specified border element using the active border style +-- using 'borderAttr'. +borderElem :: (BorderStyle -> Char) -> Widget +borderElem f = + Widget Fixed Fixed $ do + bs <- ctxBorderStyle <$> getContext + render $ withAttr borderAttr $ str [f bs] + +-- | Put a border around the specified widget. +border :: Widget -> Widget +border = border_ Nothing + +-- | Put a border around the specified widget with the specified label +-- widget placed in the middle of the top horizontal border. +borderWithLabel :: Widget + -- ^ The label widget + -> Widget + -- ^ The widget to put a border around + -> Widget +borderWithLabel label = border_ (Just label) + +border_ :: Maybe Widget -> Widget -> Widget +border_ label wrapped = + Widget (hSize wrapped) (vSize wrapped) $ do + bs <- ctxBorderStyle <$> getContext + c <- getContext + + middleResult <- render $ hLimit (c^.availWidthL - 2) + $ vLimit (c^.availHeightL - 2) + $ wrapped + + let top = (withAttr tlCornerAttr $ str [bsCornerTL bs]) + <+> hBorder_ label <+> + (withAttr trCornerAttr $ str [bsCornerTR bs]) + bottom = (withAttr blCornerAttr $ str [bsCornerBL bs]) + <+> hBorder <+> + (withAttr brCornerAttr $ str [bsCornerBR bs]) + middle = vBorder <+> (Widget Fixed Fixed $ return middleResult) <+> vBorder + total = top <=> middle <=> bottom + + render $ hLimit (middleResult^.imageL.to imageWidth + 2) + $ vLimit (middleResult^.imageL.to imageHeight + 2) + $ total + +-- | A horizontal border. Fills all horizontal space. +hBorder :: Widget +hBorder = hBorder_ Nothing + +-- | A horizontal border with a label placed in the center of the +-- border. Fills all horizontal space. +hBorderWithLabel :: Widget + -- ^ The label widget + -> Widget +hBorderWithLabel label = hBorder_ (Just label) + +hBorder_ :: Maybe Widget -> Widget +hBorder_ label = + Widget Greedy Fixed $ do + bs <- ctxBorderStyle <$> getContext + let msg = maybe (str [bsHorizontal bs]) (withAttr hBorderLabelAttr) label + render $ vLimit 1 $ withAttr hBorderAttr $ hCenterWith (Just $ bsHorizontal bs) msg + +-- | A vertical border. Fills all vertical space. +vBorder :: Widget +vBorder = + Widget Fixed Greedy $ do + bs <- ctxBorderStyle <$> getContext + render $ hLimit 1 $ withAttr vBorderAttr $ fill (bsVertical bs) diff --git a/src/Brick/Widgets/Border/Style.hs b/src/Brick/Widgets/Border/Style.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Border/Style.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides styles for borders as used in terminal +-- applications. Your mileage may vary on some of the fancier styles +-- due to varying support for some border characters in the fonts your +-- users may be using. Because of this, we provide the 'ascii' style in +-- addition to the Unicode styles. The 'unicode' style is also a safe +-- bet. +-- +-- To use these in your widgets, see +-- 'Brick.Widgets.Core.withBorderStyle'. By default, widgets rendered +-- without a specified border style use 'unicode' via the 'Default' +-- instance provided by 'BorderStyle'. +module Brick.Widgets.Border.Style + ( BorderStyle(..) + , borderStyleFromChar + , ascii + , unicode + , unicodeBold + , unicodeRounded + ) +where + +import Data.Default + +-- | A border style for use in any widget that needs to render borders +-- in a consistent style. +data BorderStyle = + BorderStyle { bsCornerTL :: Char + -- ^ Top-left corner character + , bsCornerTR :: Char + -- ^ Top-right corner character + , bsCornerBR :: Char + -- ^ Bottom-right corner character + , bsCornerBL :: Char + -- ^ Bottom-left corner character + , bsIntersectFull :: Char + -- ^ Full intersection (cross) + , bsIntersectL :: Char + -- ^ Left side of a horizontal border intersecting a vertical one + , bsIntersectR :: Char + -- ^ Right side of a horizontal border intersecting a vertical one + , bsIntersectT :: Char + -- ^ Top of a vertical border intersecting a horizontal one + , bsIntersectB :: Char + -- ^ Bottom of a vertical border intersecting a horizontal one + , bsHorizontal :: Char + -- ^ Horizontal border character + , bsVertical :: Char + -- ^ Vertical border character + } + deriving (Show, Read) + +instance Default BorderStyle where + def = unicode + +-- | Make a border style using the specified character everywhere. +borderStyleFromChar :: Char -> BorderStyle +borderStyleFromChar c = + BorderStyle c c c c c c c c c c c + +-- |An ASCII border style which will work in any terminal. +ascii :: BorderStyle +ascii = + BorderStyle { bsCornerTL = '+' + , bsCornerTR = '+' + , bsCornerBR = '+' + , bsCornerBL = '+' + , bsIntersectFull = '+' + , bsIntersectL = '+' + , bsIntersectR = '+' + , bsIntersectT = '+' + , bsIntersectB = '+' + , bsHorizontal = '-' + , bsVertical = '|' + } + +-- |A unicode border style with real corner and intersection characters. +unicode :: BorderStyle +unicode = + BorderStyle { bsCornerTL = '┌' + , bsCornerTR = '┐' + , bsCornerBR = '┘' + , bsCornerBL = '└' + , bsIntersectFull = '┼' + , bsIntersectL = '├' + , bsIntersectR = '┤' + , bsIntersectT = '┬' + , bsIntersectB = '┴' + , bsHorizontal = '─' + , bsVertical = '│' + } + +-- |A unicode border style in a bold typeface. +unicodeBold :: BorderStyle +unicodeBold = + BorderStyle { bsCornerTL = '┏' + , bsCornerTR = '┓' + , bsCornerBR = '┛' + , bsCornerBL = '┗' + , bsIntersectFull = '╋' + , bsIntersectL = '┣' + , bsIntersectR = '┫' + , bsIntersectT = '┳' + , bsIntersectB = '┻' + , bsHorizontal = '━' + , bsVertical = '┃' + } + +-- |A unicode border style with rounded corners. +unicodeRounded :: BorderStyle +unicodeRounded = + BorderStyle { bsCornerTL = '╭' + , bsCornerTR = '╮' + , bsCornerBR = '╯' + , bsCornerBL = '╰' + , bsIntersectFull = '┼' + , bsIntersectL = '├' + , bsIntersectR = '┤' + , bsIntersectT = '┬' + , bsIntersectB = '┴' + , bsHorizontal = '─' + , bsVertical = '│' + } diff --git a/src/Brick/Widgets/Center.hs b/src/Brick/Widgets/Center.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Center.hs @@ -0,0 +1,108 @@ +-- | This module provides combinators for centering other widgets. +module Brick.Widgets.Center + ( -- * Centering horizontally + hCenter + , hCenterWith + -- * Centering vertically + , vCenter + , vCenterWith + -- * Centering both horizontally and vertically + , center + , centerWith + -- * Centering about an arbitrary origin + , centerAbout + ) +where + +import Control.Lens ((^.), (&), (.~), to) +import Graphics.Vty (imageWidth, imageHeight, horizCat, charFill, vertCat) + +import Brick.Types +import Brick.Widgets.Core + +-- | Center the specified widget horizontally. Consumes all available +-- horizontal space. +hCenter :: Widget -> Widget +hCenter = hCenterWith Nothing + +-- | Center the specified widget horizontally. Consumes all available +-- horizontal space. Uses the specified character to fill in the space +-- to either side of the centered widget (defaults to space). +hCenterWith :: Maybe Char -> Widget -> Widget +hCenterWith mChar p = + let ch = maybe ' ' id mChar + in Widget Greedy (vSize p) $ do + result <- render p + c <- getContext + let rWidth = result^.imageL.to imageWidth + rHeight = result^.imageL.to imageHeight + remainder = c^.availWidthL - (leftPaddingAmount * 2) + leftPaddingAmount = (c^.availWidthL - rWidth) `div` 2 + rightPaddingAmount = leftPaddingAmount + remainder + leftPadding = charFill (c^.attrL) ch leftPaddingAmount rHeight + rightPadding = charFill (c^.attrL) ch rightPaddingAmount rHeight + paddedImage = horizCat [ leftPadding + , result^.imageL + , rightPadding + ] + off = Location (leftPaddingAmount, 0) + if leftPaddingAmount == 0 && rightPaddingAmount == 0 then + return result else + return $ addResultOffset off + $ result & imageL .~ paddedImage + +-- | Center a widget vertically. Consumes all vertical space. +vCenter :: Widget -> Widget +vCenter = vCenterWith Nothing + +-- | Center a widget vertically. Consumes all vertical space. Uses the +-- specified character to fill in the space above and below the centered +-- widget (defaults to space). +vCenterWith :: Maybe Char -> Widget -> Widget +vCenterWith mChar p = + let ch = maybe ' ' id mChar + in Widget (hSize p) Greedy $ do + result <- render p + c <- getContext + let rWidth = result^.imageL.to imageWidth + rHeight = result^.imageL.to imageHeight + remainder = c^.availHeightL - (topPaddingAmount * 2) + topPaddingAmount = (c^.availHeightL - rHeight) `div` 2 + bottomPaddingAmount = topPaddingAmount + remainder + topPadding = charFill (c^.attrL) ch rWidth topPaddingAmount + bottomPadding = charFill (c^.attrL) ch rWidth bottomPaddingAmount + paddedImage = vertCat [ topPadding + , result^.imageL + , bottomPadding + ] + off = Location (0, topPaddingAmount) + if topPaddingAmount == 0 && bottomPaddingAmount == 0 then + return result else + return $ addResultOffset off + $ result & imageL .~ paddedImage + +-- | Center a widget both vertically and horizontally. Consumes all +-- available vertical and horizontal space. +center :: Widget -> Widget +center = centerWith Nothing + +-- | Center a widget both vertically and horizontally. Consumes all +-- available vertical and horizontal space. Uses the specified character +-- to fill in the space around the centered widget (defaults to space). +centerWith :: Maybe Char -> Widget -> Widget +centerWith c = vCenterWith c . hCenterWith c + +-- | Center the widget horizontally and vertically about the specified +-- origin. +centerAbout :: Location -> Widget -> Widget +centerAbout l p = + Widget Greedy Greedy $ do + -- Compute translation offset so that loc is in the middle of the + -- rendering area + c <- getContext + let centerW = c^.availWidthL `div` 2 + centerH = c^.availHeightL `div` 2 + off = Location ( centerW - l^.columnL + , centerH - l^.rowL + ) + render $ translateBy off p diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Core.hs @@ -0,0 +1,96 @@ +-- | 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 + ( Widget(..) + , Size(..) + + -- * Basic rendering primitives + , emptyWidget + , raw + , txt + , str + , fill + + -- * Padding + , Padding(..) + , padLeft + , padRight + , padTop + , padBottom + , padLeftRight + , padTopBottom + , padAll + + -- * Box layout + , (<=>) + , (<+>) + , hBox + , vBox + + -- * Limits + , hLimit + , vLimit + + -- * Attribute mangement + , withDefAttr + , withAttr + , forceAttr + , updateAttrMap + + -- * Border style management + , withBorderStyle + + -- * Cursor placement + , showCursor + + -- * Translation + , translateBy + + -- * Cropping + , cropLeftBy + , cropRightBy + , cropTopBy + , cropBottomBy + + -- * Scrollable viewports + , ViewportType(..) + , viewport + , visible + , visibleRegion + + -- * Rendering infrastructure + , RenderM + , getContext + , lookupAttrName + + -- ** The rendering context + , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap) + , attrL + , availWidthL + , availHeightL + , ctxAttrMapL + , ctxAttrNameL + , ctxBorderStyleL + + -- ** Rendering results + , Result(..) + -- ** Result lenses + , imageL + , cursorsL + , visibilityRequestsL + -- ** Visibility requests + , VisibilityRequest(..) + , vrPositionL + , vrSizeL + -- ** Adding offsets to cursor positions and visibility requests + , addResultOffset + -- ** Cropping results + , cropToContext + + -- * Misc + , Direction(..) + ) +where + +import Brick.Widgets.Internal diff --git a/src/Brick/Widgets/Dialog.hs b/src/Brick/Widgets/Dialog.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Dialog.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides a simple dialog widget. You get to pick the +-- dialog title, if any, as well as its body and buttons. +module Brick.Widgets.Dialog + ( Dialog + , dialogTitle + , dialogName + , dialogButtons + , dialogSelectedIndex + , dialogWidth + -- * Construction and rendering + , dialog + , renderDialog + -- * Getting a dialog's current value + , dialogSelection + -- * Attributes + , dialogAttr + , buttonAttr + , buttonSelectedAttr + -- * Lenses + , dialogNameL + , dialogButtonsL + , dialogSelectedIndexL + , dialogWidthL + , dialogTitleL + ) +where + +import Control.Lens +import Control.Applicative +import Data.Monoid +import Data.List (intersperse) +import Graphics.Vty.Input (Event(..), Key(..)) + +import Brick.Util (clamp) +import Brick.Types +import Brick.Widgets.Core +import Brick.Widgets.Center +import Brick.Widgets.Border +import Brick.AttrMap + +-- | Dialogs present a window with a title (optional), a body, and +-- buttons (optional). They provide a 'HandleEvent' instance that knows +-- about Tab and Shift-Tab for changing which button is active. Dialog +-- buttons are labeled with strings and map to values of type 'a', which +-- you choose. +-- +-- Dialogs handle the following events by default: +-- +-- * Tab: selecte the next button +-- * Shift-tab: select the previous button +data Dialog a = + Dialog { dialogName :: Name + -- ^ The dialog name + , dialogTitle :: Maybe String + -- ^ The dialog title + , dialogButtons :: [(String, a)] + -- ^ The dialog button labels and values + , dialogSelectedIndex :: Maybe Int + -- ^ The currently selected dialog button index (if any) + , dialogWidth :: Int + -- ^ The maximum width of the dialog + } + +suffixLenses ''Dialog + +instance HandleEvent (Dialog a) where + handleEvent ev d = + case ev of + EvKey (KChar '\t') [] -> nextButtonBy 1 d + EvKey KBackTab [] -> nextButtonBy (-1) d + _ -> d + +-- | Create a dialog. +dialog :: Name + -- ^ The dialog name, provided so that you can use this as a + -- basis for viewport names in the dialog if desired + -> Maybe String + -- ^ The dialog title + -> Maybe (Int, [(String, a)]) + -- ^ The currently-selected button index (starting at zero) and + -- the button labels and values to use + -> Int + -- ^ The maximum width of the dialog + -> Dialog a +dialog name title buttonData w = + let (buttons, idx) = case buttonData of + Nothing -> ([], Nothing) + Just (_, []) -> ([], Nothing) + Just (i, bs) -> (bs, Just $ clamp 0 (length bs - 1) i) + in Dialog name title buttons idx w + +-- | The default attribute of the dialog +dialogAttr :: AttrName +dialogAttr = "dialog" + +-- | The default attribute for all dialog buttons +buttonAttr :: AttrName +buttonAttr = "button" + +-- | The attribute for the selected dialog button (extends 'dialogAttr') +buttonSelectedAttr :: AttrName +buttonSelectedAttr = buttonAttr <> "selected" + +-- | Render a dialog with the specified body widget. +renderDialog :: Dialog a -> Widget -> Widget +renderDialog d body = + let buttonPadding = " " + mkButton (i, (s, _)) = let att = if Just i == d^.dialogSelectedIndexL + then buttonSelectedAttr + else buttonAttr + in withAttr att $ str $ " " <> s <> " " + buttons = hBox $ intersperse buttonPadding $ + mkButton <$> (zip [0..] (d^.dialogButtonsL)) + + doBorder = maybe border borderWithLabel (str <$> d^.dialogTitleL) + in center $ + withDefAttr dialogAttr $ + hLimit (d^.dialogWidthL) $ + doBorder $ + vBox [ body + , hCenter buttons + ] + +nextButtonBy :: Int -> Dialog a -> Dialog a +nextButtonBy amt d = + let numButtons = length $ d^.dialogButtonsL + in if numButtons == 0 then d + else case d^.dialogSelectedIndexL of + Nothing -> d & dialogSelectedIndexL .~ (Just 0) + Just i -> d & dialogSelectedIndexL .~ (Just $ (i + amt) `mod` numButtons) + +-- | Obtain the value associated with the dialog's currently-selected +-- button, if any. This function is probably what you want when someone +-- presses 'Enter' in a dialog. +dialogSelection :: Dialog a -> Maybe a +dialogSelection d = + case d^.dialogSelectedIndexL of + Nothing -> Nothing + Just i -> Just $ ((d^.dialogButtonsL) !! i)^._2 diff --git a/src/Brick/Widgets/Edit.hs b/src/Brick/Widgets/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Edit.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +-- | This module provides a basic single-line text editor widget. You'll +-- need to embed an 'Editor' in your application state and transform it +-- with 'handleEvent' when relevant events arrive. To get the contents +-- of the editor, just use 'getEditContents'. To modify it, use the +-- 'Z.TextZipper' interface with 'applyEdit'. +-- +-- The editor's 'HandleEvent' instance handles a set of basic input +-- events that should suffice for most purposes; see the source for a +-- complete list. +module Brick.Widgets.Edit + ( Editor(editContents, editorName, editDrawContents) + -- * Constructing an editor + , editor + -- * Reading editor contents + , getEditContents + -- * Editing text + , applyEdit + -- * Lenses for working with editors + , editContentsL + , editDrawContentsL + -- * Rendering editors + , renderEditor + -- * Attributes + , editAttr + ) +where + +import Control.Lens +import Graphics.Vty (Event(..), Key(..), Modifier(..)) + +import qualified Data.Text.Zipper as Z + +import Brick.Types +import Brick.Widgets.Core +import Brick.AttrMap + +-- | Editor state. Editors support the following events by default: +-- +-- * Ctrl-a: go to beginning of line +-- * Ctrl-e: go to end of line +-- * Ctrl-d, Del: delete character at cursor position +-- * Backspace: delete character prior to cursor position +-- * Ctrl-k: delete all from cursor to end of line +-- * Arrow keys: move cursor +-- * Enter: break the current line at the cursor position +data Editor = + Editor { editContents :: Z.TextZipper String + -- ^ The contents of the editor + , editDrawContents :: [String] -> Widget + -- ^ The function the editor uses to draw its contents + , editorName :: Name + -- ^ The name of the editor + } + +suffixLenses ''Editor + +instance HandleEvent Editor where + handleEvent e ed = + let f = case e of + EvKey (KChar 'a') [MCtrl] -> Z.gotoBOL + EvKey (KChar 'e') [MCtrl] -> Z.gotoEOL + EvKey (KChar 'd') [MCtrl] -> Z.deleteChar + EvKey (KChar 'k') [MCtrl] -> Z.killToEOL + EvKey KEnter [] -> Z.breakLine + EvKey KDel [] -> Z.deleteChar + EvKey (KChar c) [] | c /= '\t' -> Z.insertChar c + EvKey KUp [] -> Z.moveUp + EvKey KDown [] -> Z.moveDown + EvKey KLeft [] -> Z.moveLeft + EvKey KRight [] -> Z.moveRight + EvKey KBS [] -> Z.deletePrevChar + _ -> id + in applyEdit f ed + +-- | Construct an editor. +editor :: Name + -- ^ The editor's name (must be unique) + -> ([String] -> Widget) + -- ^ The content rendering function + -> Maybe Int + -- ^ The limit on the number of lines in the editor ('Nothing' + -- means no limit) + -> String + -- ^ The initial content + -> Editor +editor name draw limit s = Editor (Z.stringZipper [s] limit) draw name + +-- | Apply an editing operation to the editor's contents. Bear in mind +-- that you should only apply zipper operations that operate on the +-- current line; the editor will only ever render the first line of +-- text. +applyEdit :: (Z.TextZipper String -> Z.TextZipper String) + -- ^ The 'Data.Text.Zipper' editing transformation to apply + -> Editor + -> Editor +applyEdit f e = e & editContentsL %~ f + +-- | The attribute assigned to the editor +editAttr :: AttrName +editAttr = "edit" + +-- | Get the contents of the editor. +getEditContents :: Editor -> [String] +getEditContents e = Z.getText $ e^.editContentsL + +-- | Turn an editor state value into a widget +renderEditor :: Editor -> Widget +renderEditor e = + let cp = Z.cursorPosition $ e^.editContentsL + cursorLoc = Location (cp^._2, cp^._1) + limit = case e^.editContentsL.to Z.getLineLimit of + Nothing -> id + Just lim -> vLimit lim + in withAttr editAttr $ + limit $ + viewport (e^.editorNameL) Both $ + showCursor (e^.editorNameL) cursorLoc $ + visibleRegion cursorLoc (1, 1) $ + e^.editDrawContentsL $ + getEditContents e diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Internal.hs @@ -0,0 +1,877 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +module Brick.Widgets.Internal + ( Result(..) + , visibilityRequestsL + , imageL + , cursorsL + , addResultOffset + + , VisibilityRequest(..) + , vrPositionL + , vrSizeL + + , RenderState(..) + , ScrollRequest(..) + , Direction(..) + + , renderFinal + , Widget(..) + , Size(..) + , RenderM + + , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap) + , lookupAttrName + , getContext + , attrL + , availWidthL + , availHeightL + , ctxAttrMapL + , ctxAttrNameL + , ctxBorderStyleL + , cropToContext + + , withBorderStyle + + , ViewportType(..) + + , txt + , str + , fill + + , Padding(..) + , padLeft + , padRight + , padTop + , padBottom + , padLeftRight + , padTopBottom + , padAll + + , emptyWidget + , hBox + , vBox + , (<=>) + , (<+>) + + , hLimit + , vLimit + , withDefAttr + , withAttr + , forceAttr + , updateAttrMap + , raw + , translateBy + , cropLeftBy + , cropRightBy + , cropTopBy + , cropBottomBy + , showCursor + , viewport + , visible + , visibleRegion + ) +where + +import Control.Applicative +import Control.Lens (makeLenses, (^.), (.~), (&), (%~), to, _1, _2, each, to, ix) +import Control.Monad (when) +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class (lift) +import qualified Data.Text as T +import Data.Default +import Data.Functor.Contravariant +import Data.Monoid ((<>), mempty) +import qualified Data.Map as M +import qualified Data.Function as DF +import Data.List (sortBy, partition) +import Control.Lens (Lens') +import Data.String (IsString(..)) +import qualified Graphics.Vty as V + +import Brick.Types +import Brick.Widgets.Border.Style +import Brick.Util (clOffset) +import Brick.AttrMap +import Brick.Util (clamp) + +data VisibilityRequest = + VR { vrPosition :: Location + , vrSize :: V.DisplayRegion + } + deriving Show + +-- | The type of viewports that indicates the direction(s) in which a +-- viewport is scrollable. +data ViewportType = Vertical + -- ^ Viewports of this type are scrollable only vertically. + | Horizontal + -- ^ Viewports of this type are scrollable only horizontally. + | Both + -- ^ Viewports of this type are scrollable vertically and horizontally. + deriving Show + +data Viewport = + VP { _vpLeft :: Int + , _vpTop :: Int + , _vpSize :: V.DisplayRegion + } + deriving Show + +-- | The type of result returned by a widget's rendering function. The +-- result provides the image, cursor positions, and visibility requests +-- that resulted from the rendering process. +data Result = + Result { image :: V.Image + -- ^ The final rendered image for a widget + , cursors :: [CursorLocation] + -- ^ The list of reported cursor positions for the + -- application to choose from + , visibilityRequests :: [VisibilityRequest] + -- ^ The list of visibility requests made by widgets rendered + -- while rendering this one (used by viewports) + } + deriving Show + +-- | The rendering context. This tells widgets how to render: how much +-- space they have in which to render, which attribute they should use +-- to render, which bordring style should be used, and the attribute map +-- available for rendering. +data Context = + Context { ctxAttrName :: AttrName + , availWidth :: Int + , availHeight :: Int + , ctxBorderStyle :: BorderStyle + , ctxAttrMap :: AttrMap + } + +-- | The type of the rendering monad. This monad is used by the +-- library's rendering routines to manage rendering state and +-- communicate rendering parameters to widgets' rendering functions. +type RenderM a = ReaderT Context (State RenderState) a + +-- | Widget growth policies. These policies communicate to layout +-- algorithms how a widget uses space when being rendered. These +-- policies influence rendering order and space allocation in the box +-- layout algorithm. +data Size = Fixed + -- ^ Fixed widgets take up the same amount of space no matter + -- how much they are given (non-greedy). + | Greedy + -- ^ Greedy widgets take up all the space they are given. + deriving (Show, Eq, Ord) + +-- | The type of widgets. +data Widget = + Widget { hSize :: Size + -- ^ This widget's horizontal growth policy + , vSize :: Size + -- ^ This widget's vertical growth policy + , render :: RenderM Result + -- ^ This widget's rendering function + } + +-- | Scrolling direction. +data Direction = Up + -- ^ Up/left + | Down + -- ^ Down/right + +data ScrollRequest = HScrollBy Int + | HScrollPage Direction + | HScrollToBeginning + | HScrollToEnd + | VScrollBy Int + | VScrollPage Direction + | VScrollToBeginning + | VScrollToEnd + +data RenderState = + RS { viewportMap :: M.Map Name Viewport + , scrollRequests :: [(Name, ScrollRequest)] + } + +suffixLenses ''Result +suffixLenses ''Context +suffixLenses ''VisibilityRequest +suffixLenses ''RenderState + +makeLenses ''Viewport + +instance IsString Widget where + fromString = str + +instance Default Result where + def = Result V.emptyImage [] [] + +-- | Get the current rendering context. +getContext :: RenderM Context +getContext = ask + +-- | When rendering the specified widget, use the specified border style +-- for any border rendering. +withBorderStyle :: BorderStyle -> Widget -> Widget +withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p) + +-- | The empty widget. +emptyWidget :: Widget +emptyWidget = raw V.emptyImage + +renderFinal :: AttrMap + -> [Widget] + -> V.DisplayRegion + -> ([CursorLocation] -> Maybe CursorLocation) + -> RenderState + -> (RenderState, V.Picture, Maybe CursorLocation) +renderFinal aMap layerRenders sz chooseCursor rs = (newRS, pic, theCursor) + where + (layerResults, newRS) = flip runState rs $ sequence $ + (\p -> runReaderT p ctx) <$> + (render <$> cropToContext <$> layerRenders) + ctx = Context def (fst sz) (snd sz) def aMap + pic = V.picForLayers $ uncurry V.resize sz <$> (^.imageL) <$> layerResults + layerCursors = (^.cursorsL) <$> layerResults + theCursor = chooseCursor $ concat layerCursors + +-- | Add an offset to all cursor locations and visbility requests +-- in the specified rendering result. This function is critical for +-- maintaining correctness in the rendering results as they are +-- processed successively by box layouts and other wrapping combinators, +-- since calls to this function result in converting from widget-local +-- coordinates to (ultimately) terminal-global ones so they can be used +-- by other combinators. You should call this any time you render +-- something and then translate it or otherwise offset it from its +-- original origin. +addResultOffset :: Location -> Result -> Result +addResultOffset off = addCursorOffset off . addVisibilityOffset off + +addVisibilityOffset :: Location -> Result -> Result +addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>) + +addCursorOffset :: Location -> Result -> Result +addCursorOffset off r = + let onlyVisible = filter isVisible + isVisible l = l^.columnL >= 0 && l^.rowL >= 0 + in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs) + +unrestricted :: Int +unrestricted = 100000 + +-- | The rendering context's current drawing attribute. +attrL :: (Contravariant f, Functor f) => (V.Attr -> f V.Attr) -> Context -> f Context +attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) + +-- | Given an attribute name, obtain the attribute for the attribute +-- name by consulting the context's attribute map. +lookupAttrName :: AttrName -> RenderM V.Attr +lookupAttrName n = do + c <- getContext + return $ attrMapLookup n (c^.ctxAttrMapL) + +-- | Build a widget from a 'String'. Breaks newlines up and space-pads +-- short lines out to the length of the longest line. +str :: String -> Widget +str s = + Widget Fixed Fixed $ do + c <- getContext + let theLines = lines s + fixEmpty [] = " " + fixEmpty l = l + case fixEmpty <$> theLines of + [] -> return def + [one] -> return $ def & imageL .~ (V.string (c^.attrL) one) + multiple -> + let maxLength = maximum $ length <$> multiple + lineImgs = lineImg <$> multiple + lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - length lStr) ' ') + in return $ def & imageL .~ (V.vertCat lineImgs) + +-- | Build a widget from a 'T.Text' value. Behaves the same as 'str'. +txt :: T.Text -> Widget +txt = str . T.unpack + +-- | 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. +padLeft :: Padding -> Widget -> Widget +padLeft padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (hLimit i, hSize p) + in Widget sz (vSize p) $ do + result <- render p + render $ (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') <+> + (Widget Fixed Fixed $ return result) + +-- | Pad the specified widget on the right. +padRight :: Padding -> Widget -> Widget +padRight padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (hLimit i, hSize p) + in Widget sz (vSize p) $ do + result <- render p + render $ (Widget Fixed Fixed $ return result) <+> + (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') + +-- | Pad the specified widget on the top. +padTop :: Padding -> Widget -> Widget +padTop padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (vLimit i, vSize p) + in Widget (hSize p) sz $ do + result <- render p + render $ (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') <=> + (Widget Fixed Fixed $ return result) + +-- | Pad the specified widget on the bottom. +padBottom :: Padding -> Widget -> Widget +padBottom padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (vLimit i, vSize p) + in Widget (hSize p) sz $ do + result <- render p + render $ (Widget Fixed Fixed $ return result) <=> + (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') + +-- | Pad a widget on the left and right. +padLeftRight :: Int -> Widget -> Widget +padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w + +-- | Pad a widget on the top and bottom. +padTopBottom :: Int -> Widget -> Widget +padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w + +-- | Pad a widget on all sides. +padAll :: Int -> Widget -> Widget +padAll v w = padLeftRight v $ padTopBottom v w + +-- | Fill all available space with the specified character. Grows both +-- horizontally and vertically. +fill :: Char -> Widget +fill ch = + Widget Greedy Greedy $ do + c <- getContext + return $ def & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL)) + +-- | Vertical box layout: put the specified widgets one above the other +-- in the specified order (uppermost first). Defers growth policies to +-- the growth policies of both widgets. +vBox :: [Widget] -> Widget +vBox [] = emptyWidget +vBox pairs = renderBox vBoxRenderer pairs + +-- | Horizontal box layout: put the specified widgets next to each other +-- in the specified order (leftmost first). Defers growth policies to +-- the growth policies of both widgets. +hBox :: [Widget] -> Widget +hBox [] = emptyWidget +hBox pairs = renderBox hBoxRenderer pairs + +-- | The process of rendering widgets in a box layout is exactly the +-- same except for the dimension under consideration (width vs. height), +-- in which case all of the same operations that consider one dimension +-- in the layout algorithm need to be switched to consider the other. +-- Because of this we fill a BoxRenderer with all of the functions +-- needed to consider the "primary" dimension (e.g. vertical if the +-- box layout is vertical) as well as the "secondary" dimension (e.g. +-- horizontal if the box layout is vertical). Doing this permits us to +-- have one implementation for box layout and parameterizing on the +-- orientation of all of the operations. +data BoxRenderer = + BoxRenderer { contextPrimary :: Lens' Context Int + , contextSecondary :: Lens' Context Int + , imagePrimary :: V.Image -> Int + , imageSecondary :: V.Image -> Int + , limitPrimary :: Int -> Widget -> Widget + , limitSecondary :: Int -> Widget -> Widget + , primaryWidgetSize :: Widget -> Size + , concatenatePrimary :: [V.Image] -> V.Image + , locationFromOffset :: Int -> Location + , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image + } + +vBoxRenderer :: BoxRenderer +vBoxRenderer = + BoxRenderer { contextPrimary = availHeightL + , contextSecondary = availWidthL + , imagePrimary = V.imageHeight + , imageSecondary = V.imageWidth + , limitPrimary = vLimit + , limitSecondary = hLimit + , primaryWidgetSize = vSize + , concatenatePrimary = V.vertCat + , locationFromOffset = Location . (0 ,) + , padImageSecondary = \amt img a -> + let p = V.charFill a ' ' amt (V.imageHeight img) + in V.horizCat [img, p] + } + +hBoxRenderer :: BoxRenderer +hBoxRenderer = + BoxRenderer { contextPrimary = availWidthL + , contextSecondary = availHeightL + , imagePrimary = V.imageWidth + , imageSecondary = V.imageHeight + , limitPrimary = hLimit + , limitSecondary = vLimit + , primaryWidgetSize = hSize + , concatenatePrimary = V.horizCat + , locationFromOffset = Location . (, 0) + , padImageSecondary = \amt img a -> + let p = V.charFill a ' ' (V.imageWidth img) amt + in V.vertCat [img, p] + } + +-- | Render a series of widgets in a box layout in the order given. +-- +-- The growth policy of a box layout is the most unrestricted of the +-- growth policies of the widgets it contains, so to determine the hSize +-- and vSize of the box we just take the maximum (using the Ord instance +-- for Size) of all of the widgets to be rendered in the box. +-- +-- Then the box layout algorithm proceeds as follows. We'll use +-- the vertical case to concretely describe the algorithm, but the +-- horizontal case can be envisioned just by exchanging all +-- "vertical"/"horizontal" and "rows"/"columns", etc., in the +-- description. +-- +-- The growth policies of the child widgets determine the order in which +-- they are rendered, i.e., the order in which space in the box is +-- allocated to widgets as the algorithm proceeds. This is because order +-- matters: if we render greedy widgets first, there will be no space +-- left for non-greedy ones. +-- +-- So we render all widgets with size 'Fixed' in the vertical dimension +-- first. Each is rendered with as much room as the overall box has, but +-- we assume that they will not be greedy and use it all. If they do, +-- maybe it's because the terminal is small and there just isn't enough +-- room to render everything. +-- +-- Then the remaining height is distributed evenly amongst all remaining +-- (greedy) widgets and they are rendered in sub-boxes that are as high +-- as this even slice of rows and as wide as the box is permitted to be. +-- We only do this step at all if rendering the non-greedy widgets left +-- us any space, i.e., if there were any rows left. +-- +-- After rendering the non-greedy and then greedy widgets, their images +-- are sorted so that they are stored in the order the original widgets +-- were given. All cursor locations and visibility requests in each +-- sub-widget are translated according to the position of the sub-widget +-- in the box. +-- +-- All images are padded to be as wide as the widest sub-widget to +-- prevent attribute over-runs. Without this step the attribute used by +-- a sub-widget may continue on in an undesirable fashion until it hits +-- something with a different attribute. To prevent this and to behave +-- in the least surprising way, we pad the image on the right with +-- whitespace using the context's current attribute. +-- +-- Finally, the padded images are concatenated together vertically and +-- returned along with the translated cursor positions and visibility +-- requests. +renderBox :: BoxRenderer -> [Widget] -> Widget +renderBox br ws = do + Widget (maximum $ hSize <$> ws) (maximum $ vSize <$> ws) $ do + c <- getContext + + let pairsIndexed = zip [(0::Int)..] ws + (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed) pairsIndexed + + renderedHis <- mapM (\(i, prim) -> (i,) <$> render prim) his + + renderedLows <- case lows of + [] -> return [] + ls -> do + let remainingPrimary = c^.(contextPrimary br) - (sum $ (^._2.imageL.(to $ imagePrimary br)) <$> renderedHis) + primaryPerLow = remainingPrimary `div` length ls + padFirst = remainingPrimary - (primaryPerLow * length ls) + secondaryPerLow = c^.(contextSecondary br) + primaries = replicate (length ls) primaryPerLow & ix 0 %~ (+ padFirst) + + let renderLow ((i, prim), pri) = + (i,) <$> (render $ limitPrimary br pri + $ limitSecondary br secondaryPerLow + $ cropToContext prim) + + if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return [] + + let rendered = sortBy (compare `DF.on` fst) $ renderedHis ++ renderedLows + allResults = snd <$> rendered + allImages = (^.imageL) <$> allResults + allPrimaries = imagePrimary br <$> allImages + allTranslatedResults = (flip map) (zip [0..] allResults) $ \(i, result) -> + let off = locationFromOffset br offPrimary + offPrimary = sum $ take i allPrimaries + in addResultOffset off result + -- Determine the secondary dimension value to pad to. In a + -- vertical box we want all images to be the same width to + -- avoid attribute over-runs or blank spaces with the wrong + -- attribute. In a horizontal box we want all images to have + -- the same height for the same reason. + maxSecondary = maximum $ imageSecondary br <$> allImages + padImage img = padImageSecondary br (maxSecondary - imageSecondary br img) img (c^.attrL) + paddedImages = padImage <$> allImages + + cropResultToContext $ Result (concatenatePrimary br paddedImages) + (concat $ cursors <$> allTranslatedResults) + (concat $ visibilityRequests <$> allTranslatedResults) + +-- | Limit the space available to the specified widget to the specified +-- number of columns. This is important for constraining the horizontal +-- growth of otherwise-greedy widgets. +hLimit :: Int -> Widget -> Widget +hLimit w p = + Widget Fixed (vSize p) $ do + withReaderT (& availWidthL .~ w) $ render $ cropToContext p + +-- | Limit the space available to the specified widget to the specified +-- number of rows. This is important for constraining the vertical +-- growth of otherwise-greedy widgets. +vLimit :: Int -> Widget -> Widget +vLimit h p = + Widget (hSize p) Fixed $ do + withReaderT (& availHeightL .~ h) $ render $ cropToContext p + +-- | When drawing the specified widget, set the current attribute used +-- for drawing to the one with the specified name. Note that the widget +-- may use further calls to 'withAttr' to override this; if you really +-- want to prevent that, use 'forceAttr'. Attributes used this way still +-- get merged hierarchically and still fall back to the attribute map's +-- default attribute. If you want to change the default attribute, use +-- 'withDefAttr'. +withAttr :: AttrName -> Widget -> Widget +withAttr an p = + Widget (hSize p) (vSize p) $ do + withReaderT (& ctxAttrNameL .~ an) (render p) + +-- | Update the attribute map while rendering the specified widget: set +-- its new default attribute to the one that we get by looking up the +-- specified attribute name in the map. +withDefAttr :: AttrName -> Widget -> Widget +withDefAttr an p = + Widget (hSize p) (vSize p) $ do + c <- getContext + withReaderT (& ctxAttrMapL %~ (setDefault (attrMapLookup an (c^.ctxAttrMapL)))) (render p) + +-- | When rendering the specified widget, update the attribute map with +-- the specified transformation. +updateAttrMap :: (AttrMap -> AttrMap) -> Widget -> Widget +updateAttrMap f p = + Widget (hSize p) (vSize p) $ do + withReaderT (& ctxAttrMapL %~ f) (render p) + +-- | When rendering the specified widget, force all attribute lookups +-- in the attribute map to use the value currently assigned to the +-- specified attribute name. +forceAttr :: AttrName -> Widget -> Widget +forceAttr an p = + Widget (hSize p) (vSize p) $ do + c <- getContext + withReaderT (& ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p) + +-- | Build a widget directly from a raw Vty image. +raw :: V.Image -> Widget +raw img = Widget Fixed Fixed $ return $ def & imageL .~ img + +-- | Translate the specified widget by the specified offset amount. +translateBy :: Location -> Widget -> Widget +translateBy off p = + Widget (hSize p) (vSize p) $ do + result <- render p + return $ addResultOffset off + $ result & imageL %~ (V.translate (off^.columnL) (off^.rowL)) + +cropResultToContext :: Result -> RenderM Result +cropResultToContext result = do + c <- getContext + return $ result & imageL %~ (V.crop (c^.availWidthL) (c^.availHeightL)) + +-- | After rendering the specified widget, crop its result image to the +-- dimensions in the rendering context. +cropToContext :: Widget -> Widget +cropToContext p = + Widget (hSize p) (vSize p) $ (render p >>= cropResultToContext) + +-- | Crop the specified widget on the left by the specified number of +-- columns. +cropLeftBy :: Int -> Widget -> Widget +cropLeftBy cols p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageWidth (result^.imageL) - cols + cropped img = if amt < 0 then V.emptyImage else V.cropLeft amt img + return $ addResultOffset (Location (-1 * cols, 0)) + $ result & imageL %~ cropped + +-- | Crop the specified widget on the right by the specified number of +-- columns. +cropRightBy :: Int -> Widget -> Widget +cropRightBy cols p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageWidth (result^.imageL) - cols + cropped img = if amt < 0 then V.emptyImage else V.cropRight amt img + return $ result & imageL %~ cropped + +-- | Crop the specified widget on the top by the specified number of +-- rows. +cropTopBy :: Int -> Widget -> Widget +cropTopBy rows p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageHeight (result^.imageL) - rows + cropped img = if amt < 0 then V.emptyImage else V.cropTop amt img + return $ addResultOffset (Location (0, -1 * rows)) + $ result & imageL %~ cropped + +-- | Crop the specified widget on the bottom by the specified number of +-- rows. +cropBottomBy :: Int -> Widget -> Widget +cropBottomBy rows p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageHeight (result^.imageL) - rows + cropped img = if amt < 0 then V.emptyImage else V.cropBottom amt img + return $ result & imageL %~ cropped + +-- | When rendering the specified widget, also register a cursor +-- positioning request using the specified name and location. +showCursor :: Name -> Location -> Widget -> Widget +showCursor n cloc p = + Widget (hSize p) (vSize p) $ do + result <- render p + return $ result & cursorsL %~ (CursorLocation cloc (Just n):) + +hRelease :: Widget -> Maybe Widget +hRelease p = + case hSize p of + Fixed -> Just $ Widget Greedy (vSize p) $ withReaderT (& availWidthL .~ unrestricted) (render p) + Greedy -> Nothing + +vRelease :: Widget -> Maybe Widget +vRelease p = + case vSize p of + Fixed -> Just $ Widget (hSize p) Greedy $ withReaderT (& availHeightL .~ unrestricted) (render p) + Greedy -> Nothing + +-- | Render the specified widget in a named viewport with the +-- specified type. This permits widgets to be scrolled without being +-- scrolling-aware. To make the most use of viewports, the specified +-- widget should use the 'visible' combinator to make a "visibility +-- request". This viewport combinator will then translate the resulting +-- rendering to make the requested region visible. In addition, the +-- 'Brick.Main.EventM' monad provides primitives to scroll viewports +-- created by this function if 'visible' is not what you want. +-- +-- If a viewport receives more than one visibility request, only the +-- first is honored. If a viewport receives more than one scrolling +-- request from 'Brick.Main.EventM', all are honored in the order in +-- which they are received. +viewport :: Name + -- ^ The name of the viewport (must be unique and stable for + -- reliable behavior) + -> ViewportType + -- ^ The type of viewport (indicates the permitted scrolling + -- direction) + -> Widget + -- ^ The widget to be rendered in the scrollable viewport + -> Widget +viewport vpname typ p = + Widget Greedy Greedy $ do + -- First, update the viewport size. + c <- getContext + let newVp = VP 0 0 newSize + newSize = (c^.availWidthL, c^.availHeightL) + doInsert (Just vp) = Just $ vp & vpSize .~ newSize + doInsert Nothing = Just newVp + + lift $ modify (& viewportMapL %~ (M.alter doInsert vpname)) + + -- Then render the sub-rendering with the rendering layout + -- constraint released (but raise an exception if we are asked to + -- render an infinitely-sized widget in the viewport's scrolling + -- dimension) + let Name vpn = vpname + release = case typ of + Vertical -> vRelease + Horizontal -> hRelease + Both -> \w -> vRelease w >>= hRelease + released = case release p of + Just w -> w + Nothing -> case typ of + Vertical -> error $ "tried to embed an infinite-height widget in vertical viewport " <> (show vpn) + Horizontal -> error $ "tried to embed an infinite-width widget in horizontal viewport " <> (show vpn) + Both -> error $ "tried to embed an infinite-width or infinite-height widget in 'Both' type viewport " <> (show vpn) + + initialResult <- render released + + -- If the sub-rendering requested visibility, update the scroll + -- state accordingly + when (not $ null $ initialResult^.visibilityRequestsL) $ do + Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) + let rq = head $ initialResult^.visibilityRequestsL + updatedVp = case typ of + Both -> scrollToView Horizontal rq $ scrollToView Vertical rq vp + Horizontal -> scrollToView typ rq vp + Vertical -> scrollToView typ rq vp + lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) + + -- If the rendering state includes any scrolling requests for this + -- viewport, apply those + reqs <- lift $ gets $ (^.scrollRequestsL) + let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs + when (not $ null relevantRequests) $ do + Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) + let updatedVp = applyRequests relevantRequests vp + applyRequests [] v = v + applyRequests (rq:rqs) v = + case typ of + Horizontal -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v + Vertical -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v + Both -> scrollTo Horizontal rq (initialResult^.imageL) $ + scrollTo Vertical rq (initialResult^.imageL) $ + applyRequests rqs v + lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) + return () + + -- Get the viewport state now that it has been updated. + Just vp <- lift $ gets (M.lookup vpname . (^.viewportMapL)) + + -- Then perform a translation of the sub-rendering to fit into the + -- viewport + translated <- render $ translateBy (Location (-1 * vp^.vpLeft, -1 * vp^.vpTop)) + $ Widget Fixed Fixed $ return initialResult + + -- Return the translated result with the visibility requests + -- discarded + let translatedSize = ( translated^.imageL.to V.imageWidth + , translated^.imageL.to V.imageHeight + ) + case translatedSize of + (0, 0) -> return $ translated & imageL .~ (V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL)) + & visibilityRequestsL .~ mempty + _ -> render $ cropToContext + $ padBottom Max + $ padRight Max + $ Widget Fixed Fixed $ return $ translated & visibilityRequestsL .~ mempty + +scrollTo :: ViewportType -> ScrollRequest -> V.Image -> Viewport -> Viewport +scrollTo Both _ _ _ = error "BUG: called scrollTo on viewport type 'Both'" +scrollTo Vertical req img vp = vp & vpTop .~ newVStart + where + newVStart = clamp 0 (V.imageHeight img - vp^.vpSize._2) adjustedAmt + adjustedAmt = case req of + VScrollBy amt -> vp^.vpTop + amt + VScrollPage Up -> vp^.vpTop - vp^.vpSize._2 + VScrollPage Down -> vp^.vpTop + vp^.vpSize._2 + VScrollToBeginning -> 0 + VScrollToEnd -> V.imageHeight img - vp^.vpSize._2 + _ -> vp^.vpTop +scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart + where + newHStart = clamp 0 (V.imageWidth img - vp^.vpSize._1) adjustedAmt + adjustedAmt = case req of + HScrollBy amt -> vp^.vpLeft + amt + HScrollPage Up -> vp^.vpLeft - vp^.vpSize._1 + HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1 + HScrollToBeginning -> 0 + HScrollToEnd -> V.imageWidth img - vp^.vpSize._1 + _ -> vp^.vpLeft + +scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport +scrollToView Both _ _ = error "BUG: called scrollToView on 'Both' type viewport" +scrollToView Vertical rq vp = vp & vpTop .~ newVStart + where + curStart = vp^.vpTop + curEnd = curStart + vp^.vpSize._2 + reqStart = rq^.vrPositionL.rowL + + reqEnd = rq^.vrPositionL.rowL + rq^.vrSizeL._2 + newVStart :: Int + newVStart = if reqStart < curStart + then reqStart + else if reqStart > curEnd || reqEnd > curEnd + then reqEnd - vp^.vpSize._2 + else curStart +scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart + where + curStart = vp^.vpLeft + curEnd = curStart + vp^.vpSize._1 + reqStart = rq^.vrPositionL.columnL + + reqEnd = rq^.vrPositionL.columnL + rq^.vrSizeL._1 + newHStart :: Int + newHStart = if reqStart < curStart + then reqStart + else if reqStart > curEnd || reqEnd > curEnd + then reqEnd - vp^.vpSize._1 + else curStart + +-- | Request that the specified widget be made visible when it is +-- rendered inside a viewport. This permits widgets (whose sizes and +-- positions cannot be known due to being embedded in arbitrary layouts) +-- to make a request for a parent viewport to locate them and scroll +-- enough to put them in view. This, together with 'viewport', is what +-- makes the text editor and list widgets possible without making them +-- deal with the details of scrolling state management. +-- +-- This does nothing if not rendered in a viewport. +visible :: Widget -> Widget +visible p = + Widget (hSize p) (vSize p) $ do + result <- render p + let imageSize = ( result^.imageL.to V.imageWidth + , result^.imageL.to V.imageHeight + ) + -- The size of the image to be made visible in a viewport must have + -- non-zero size in both dimensions. + return $ if imageSize^._1 > 0 && imageSize^._2 > 0 + then result & visibilityRequestsL %~ (VR (Location (0, 0)) imageSize :) + else result + +-- | Similar to 'visible', request that a region (with the specified +-- 'Location' as its origin and 'V.DisplayRegion' as its size) be made +-- visible when it is rendered inside a viewport. The 'Location' is +-- relative to the specified widget's upper-left corner of (0, 0). +-- +-- This does nothing if not rendered in a viewport. +visibleRegion :: Location -> V.DisplayRegion -> Widget -> Widget +visibleRegion vrloc sz p = + Widget (hSize p) (vSize p) $ do + result <- render p + -- The size of the image to be made visible in a viewport must have + -- non-zero size in both dimensions. + return $ if sz^._1 > 0 && sz^._2 > 0 + then result & visibilityRequestsL %~ (VR vrloc sz :) + else result + +-- | Horizontal box layout: put the specified widgets next to each other +-- in the specified order. Defers growth policies to the growth policies +-- of both widgets. This operator is a binary version of 'hBox'. +(<+>) :: Widget + -- ^ Left + -> Widget + -- ^ Right + -> Widget +(<+>) a b = hBox [a, b] + +-- | Vertical box layout: put the specified widgets one above the other +-- in the specified order. Defers growth policies to the growth policies +-- of both widgets. This operator is a binary version of 'vBox'. +(<=>) :: Widget + -- ^ Top + -> Widget + -- ^ Bottom + -> Widget +(<=>) a b = vBox [a, b] diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/List.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +-- | This module provides a scrollable list type and functions for +-- manipulating and rendering it. +module Brick.Widgets.List + ( List(listElements, listSelected, listName, listElementDraw) + + -- * Consructing a list + , list + + -- * Rendering a list + , renderList + + -- * Lenses + , listElementsL + , listSelectedL + , listNameL + + -- * Manipulating a list + , listMoveBy + , listMoveTo + , listMoveUp + , listMoveDown + , listInsert + , listRemove + , listReplace + , listSelectedElement + + -- * Attributes + , listAttr + , listSelectedAttr + ) +where + +import Control.Applicative ((<$>)) +import Control.Lens ((^.), (&), (.~)) +import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe) +import qualified Data.Algorithm.Diff as D +import Graphics.Vty (Event(..), Key(..)) + +import Brick.Types +import Brick.Widgets.Core +import Brick.Util (clamp) +import Brick.AttrMap + +-- | List state. Lists have an element type 'e' that is the data stored +-- by the list. Lists handle the following events by default: +-- +-- * Up/down arrow keys: move cursor of selected item +data List e = + List { listElements :: ![e] + , listElementDraw :: Bool -> e -> Widget + , listSelected :: !(Maybe Int) + , listName :: Name + } + +suffixLenses ''List + +instance HandleEvent (List e) where + handleEvent e theList = f theList + where + f = case e of + EvKey KUp [] -> listMoveUp + EvKey KDown [] -> listMoveDown + _ -> id + +-- | The top-level attribute used for the entire list. +listAttr :: AttrName +listAttr = "list" + +-- | The attribute used only for the currently-selected list item. +-- Extends 'listAttr'. +listSelectedAttr :: AttrName +listSelectedAttr = listAttr <> "selected" + +-- | Construct a list in terms of an element type 'e'. +list :: Name + -- ^ The list name (must be unique) + -> (Bool -> e -> Widget) + -- ^ The item rendering function (takes the item and whether it is + -- currently selected) + -> [e] + -- ^ The initial list contents + -> List e +list name draw es = + let selIndex = if null es then Nothing else Just 0 + in List es draw selIndex name + +-- | Turn a list state value into a widget. +renderList :: List e -> Widget +renderList l = withDefAttr listAttr $ + viewport (l^.listNameL) Vertical $ + vBox $ + drawListElements l + +drawListElements :: List e -> [Widget] +drawListElements l = drawnElements + where + es = l^.listElementsL + drawnElements = (flip map) (zip [0..] es) $ \(i, e) -> + let isSelected = Just i == l^.listSelectedL + elemWidget = (l^.listElementDrawL) isSelected e + makeVisible = if isSelected + then (visible . withDefAttr listSelectedAttr) + else id + in makeVisible elemWidget + +-- | Insert an item into a list at the specified position. +listInsert :: Int + -- ^ The position at which to insert (0 <= i <= size) + -> e + -- ^ The element to insert + -> List e + -> List e +listInsert pos e l = + let safePos = clamp 0 (length es) pos + es = l^.listElementsL + newSel = case l^.listSelectedL of + Nothing -> 0 + Just s -> if safePos < s + then s + 1 + else s + (front, back) = splitAt safePos es + in l & listSelectedL .~ Just newSel + & listElementsL .~ (front ++ (e : back)) + +-- | Remove an element from a list at the specified position. +listRemove :: Int + -- ^ The position at which to remove an element (0 <= i < size) + -> List e + -> List e +listRemove pos l | null (l^.listElementsL) = l + | pos /= clamp 0 (length (l^.listElementsL) - 1) pos = l + | otherwise = + let newSel = case l^.listSelectedL of + Nothing -> 0 + Just s -> if pos == 0 + then 0 + else if pos == s + then pos - 1 + else if pos < s + then s - 1 + else s + (front, back) = splitAt pos es + es' = front ++ tail back + es = l^.listElementsL + in l & listSelectedL .~ (if null es' then Nothing else Just newSel) + & listElementsL .~ es' + +-- | Replace the contents of a list with a new set of elements but +-- preserve the currently selected index. +listReplace :: Eq e => [e] -> List e -> List e +listReplace es' l | es' == l^.listElementsL = l + | otherwise = + let sel = fromMaybe 0 (l^.listSelectedL) + getNewSel es = case (null es, null es') of + (_, True) -> Nothing + (True, False) -> Just 0 + (False, False) -> Just (maintainSel es es' sel) + newSel = getNewSel (l^.listElementsL) + + in l & listSelectedL .~ newSel + & listElementsL .~ es' + +-- | Move the list selected index up by one. (Moves the cursor up, +-- subtracts one from the index.) +listMoveUp :: List e -> List e +listMoveUp = listMoveBy (-1) + +-- | Move the list selected index down by one. (Moves the cursor down, +-- adds one to the index.) +listMoveDown :: List e -> List e +listMoveDown = listMoveBy 1 + +-- | Move the list selected index by the specified amount, subject to +-- validation. +listMoveBy :: Int -> List e -> List e +listMoveBy amt l = + let newSel = clamp 0 (length (l^.listElementsL) - 1) <$> (amt +) <$> (l^.listSelectedL) + in l & listSelectedL .~ newSel + +-- | Set the selected index for a list to the specified index, subject +-- to validation. +listMoveTo :: Int -> List e -> List e +listMoveTo pos l = + let len = length (l^.listElementsL) + newSel = clamp 0 (len - 1) $ if pos < 0 then (len - pos) else pos + in l & listSelectedL .~ if len > 0 + then Just newSel + else Nothing + +-- | Return a list's selected element, if any. +listSelectedElement :: List e -> Maybe (Int, e) +listSelectedElement l = do + sel <- l^.listSelectedL + return (sel, (l^.listElementsL) !! sel) + +-- Assuming `xs` is an existing list that we want to update to match the +-- state of `ys`. Given a selected index in `xs`, the goal is to compute +-- the corresponding index in `ys`. +maintainSel :: (Eq e) => [e] -> [e] -> Int -> Int +maintainSel xs ys sel = let hunks = D.getDiff xs ys + in merge 0 sel hunks + +merge :: (Eq e) => Int -> Int -> [D.Diff e] -> Int +merge _ sel [] = sel +merge idx sel (h:hs) | idx > sel = sel + | otherwise = case h of + D.Both _ _ -> merge sel (idx + 1) hs + + -- element removed in new list + D.First _ -> let newSel = if idx < sel + then sel - 1 + else sel + in merge newSel idx hs + + -- element added in new list + D.Second _ -> let newSel = if idx <= sel + then sel + 1 + else sel + in merge newSel (idx + 1) hs diff --git a/src/Brick/Widgets/ProgressBar.hs b/src/Brick/Widgets/ProgressBar.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/ProgressBar.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides a progress bar widget. +module Brick.Widgets.ProgressBar + ( progressBar + -- * Attributes + , progressCompleteAttr + , progressIncompleteAttr + ) +where + +import Control.Lens ((^.)) +import Data.Monoid + +import Brick.AttrMap +import Brick.Widgets.Core + +-- | The attribute of the completed portion of the progress bar. +progressCompleteAttr :: AttrName +progressCompleteAttr = "progressComplete" + +-- | The attribute of the incomplete portion of the progress bar. +progressIncompleteAttr :: AttrName +progressIncompleteAttr = "progressIncomplete" + +-- | Draw a progress bar with the specified (optional) label and +-- progress value. This fills available horizontal space and is one row +-- high. +progressBar :: 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 +progressBar mLabel progress = + Widget Greedy Fixed $ do + c <- getContext + let barWidth = c^.availWidthL + label = maybe "" id mLabel + labelWidth = length label + spacesWidth = barWidth - labelWidth + leftPart = replicate (spacesWidth `div` 2) ' ' + rightPart = replicate (barWidth - (labelWidth + length leftPart)) ' ' + fullBar = leftPart <> label <> rightPart + completeWidth = round $ progress * toEnum barWidth + completePart = take completeWidth fullBar + incompletePart = drop completeWidth fullBar + render $ (withAttr progressCompleteAttr $ str completePart) <+> + (withAttr progressIncompleteAttr $ str incompletePart) diff --git a/src/Data/Text/Markup.hs b/src/Data/Text/Markup.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Markup.hs @@ -0,0 +1,74 @@ +-- | This module provides an API for "marking up" text with arbitrary +-- values. A piece of markup can then be converted to a list of pairs +-- representing the sequences of characters assigned the same markup +-- value. +-- +-- This interface is experimental. Don't use this for your full-file +-- syntax highlighter just yet! +module Data.Text.Markup + ( Markup + , markupToList + , markupSet + , fromList + , fromText + , toText + , (@@) + ) +where + +import Control.Applicative ((<$>)) +import Data.Default (Default, def) +import Data.Monoid +import Data.String (IsString(..)) +import qualified Data.Text as T + +-- | Markup with metadata type 'a' assigned to each character. +data Markup a = Markup [(Char, a)] + deriving Show + +instance Monoid (Markup a) where + mempty = Markup mempty + mappend (Markup t1) (Markup t2) = + Markup (t1 `mappend` t2) + +instance (Default a) => IsString (Markup a) where + fromString = fromText . T.pack + +-- | Build a piece of markup; assign the specified metadata to every +-- character in the specified text. +(@@) :: T.Text -> a -> Markup a +t @@ val = Markup [(c, val) | c <- T.unpack t] + +-- | Build markup from text with the default metadata. +fromText :: (Default a) => T.Text -> Markup a +fromText = (@@ def) + +-- | Extract the text from markup, discarding the markup metadata. +toText :: (Eq a) => Markup a -> T.Text +toText = T.concat . (fst <$>) . markupToList + +-- | Set the metadata for a range of character positions in a piece of +-- markup. This is useful for, e.g., syntax highlighting. +markupSet :: (Eq a) => (Int, Int) -> a -> Markup a -> Markup a +markupSet (start, len) val m@(Markup l) = if start < 0 || start + len > length l + then m + else newM + where + newM = Markup $ theHead ++ theNewEntries ++ theTail + (theHead, theLongTail) = splitAt start l + (theOldEntries, theTail) = splitAt len theLongTail + theNewEntries = zip (fst <$> theOldEntries) (repeat val) + +-- | Convert markup to a list of pairs in which each pair contains the +-- longest subsequence of characters having the same metadata. +markupToList :: (Eq a) => Markup a -> [(T.Text, a)] +markupToList (Markup thePairs) = toList thePairs + where + toList [] = [] + toList ((ch, val):rest) = (T.pack $ ch : (fst <$> matching), val) : toList remaining + where + (matching, remaining) = break (\(_, v) -> v /= val) rest + +-- | Convert a list of text and metadata pairs into markup. +fromList :: [(T.Text, a)] -> Markup a +fromList pairs = Markup $ concatMap (\(t, val) -> [(c, val) | c <- T.unpack t]) pairs