diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, Jonathan Daugherty. +Copyright (c) 2009-2011, Jonathan Daugherty. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,9 @@ + +vty-ui-users-manual.pdf: *.tex ch[1234]/*.tex + # Run it twice so the TOC gets generated properly + pdflatex -shell-escape vty-ui-users-manual.tex + pdflatex -shell-escape vty-ui-users-manual.tex + +clean: + rm -f *~ *.dvi *.pdf *.log *.aux *.toc *.out + rm -f ch[1234]/*.aux ch[1234]/*~ diff --git a/doc/ch1/api_notes.tex b/doc/ch1/api_notes.tex new file mode 100644 --- /dev/null +++ b/doc/ch1/api_notes.tex @@ -0,0 +1,34 @@ +\section{Conventions and API Notes} + +When you create a widget in \vtyui, the result with almost always have +a type like \fw{Widget a}. The type variable \fw{a} represents the +specific type of state the widget can carry, and therefore which +operations can be performed on it. For example, a text widget has +type \fw{Widget FormattedText}. Throughout this document, we'll refer +frequently to widgets by their state type (e.g., ``\fw{Edit} +widgets''). In most cases we are referring to a value whose type is, +e.g., \fw{Widget Edit}. When in doubt, be sure to check the API +documentation. + +The \fw{Widget} type is actually an \fw{IORef} which wraps the real +widget implementation type, \fw{WidgetImpl a}. So it's best to use +\fw{Widget a} whenever you need to refer to a widget; this makes it +possible to mutate widget state when events occur in your application. + +All widget constructors must ultimately be run in the \fw{IO} monad, +so all API functions must be run in an instance of \fw{MonadIO}. In +this manual we will use \fw{IO} to simplify type signatures, but keep +in mind that the actual type is likely to be \fw{(MonadIO m) => m}. +Although \fw{MonadIO} is by far the more common constraint, be sure to +check the API documentation to be sure; some functions, such as event +handlers, are \fw{IO} actions. + +Regarding return values, even if a function is of type \fw{...\ -> IO + a}, we say it is ``in the \fw{IO} monad'' and \textit{returns} +\fw{a}. We won't bother saying that a function \textit{returns \fw{IO + a}}. + +Lastly, we will refer to the many \vtyui\ library modules throughout +this document. We will almost always omit the +\fw{Graphics.Vty.Widgets} module namespace prefix and will instead +refer to the modules by their short names. diff --git a/doc/ch1/getting_started.tex b/doc/ch1/getting_started.tex new file mode 100644 --- /dev/null +++ b/doc/ch1/getting_started.tex @@ -0,0 +1,141 @@ +\section{Getting Started} +\label{sec:gettingStarted} + +To get started using the library, you'll need to import the main library +module: + +\begin{haskellcode} + import Graphics.Vty.Widgets.All +\end{haskellcode} + +The \fw{All} module exports everything exported by the library; if you +prefer, you may import specific modules depending on your needs. + +As a demonstration, we'll create a program which presents an editing +widget in the middle of the screen. You'll be able to provide some +text input and press Enter, at which point the program will exit and +will print what you entered. The code for this program is as follows: + +\begin{haskellcode} + main :: IO () + main = do + e <- editWidget + ui <- centered e + + fg <- newFocusGroup + addToFocusGroup fg e + + c <- newCollection + addToCollection c ui fg + + e `onActivate` \this -> + getEditText this >>= (error . ("You entered: " ++)) + + runUi c defaultContext +\end{haskellcode} + +There are some interesting things to note about this program. First, +it withstands changes in your terminal size automatically, even though +the size of the terminal is not an explicit part of the program. +Second, it only took a few lines of code to create a rich editing +interface and position it in the terminal as desired. Now we'll go +into some depth on this example. + +\begin{haskellcode} + e <- editWidget +\end{haskellcode} + +This line creates an \fw{Edit} widget. This type of widget provides +an editing interface for a single line of text and supports some +Emacs-style editing keybindings. The \fw{Edit} widget also takes care +of horizontal scrolling when its input doesn't fit into the allowed +space. For more information on this widget type, see Section +\ref{sec:edit}. + +\begin{haskellcode} + ui <- centered e +\end{haskellcode} + +This creates a new \fw{Centered} widget, \fw{ui}, which centers the +\fw{Edit} widget vertically and horizontally. This is a common +pattern: create one widget and wrap it in another to affect its +behavior. For more information on the \fw{Centered} widget type, see +Section \ref{sec:centering}. + +\begin{haskellcode} + fg <- newFocusGroup +\end{haskellcode} + +This creates a \fw{FocusGroup} widget. A ``focus group'' is an +ordered sequence of widgets that will receive focus as you cycle +between them. By default, this cycling is done with the \fw{Tab} key. +Every \vtyui\ interface requires a focus group. + +\begin{haskellcode} + addToFocusGroup fg e +\end{haskellcode} + +This adds the \fw{Edit} widget to the \fw{FocusGroup}. The first +widget to be added to a \fw{Focus\-Group} automatically receives the +initial focus, and widgets receive focus in the order in which they +are added to the group. + +\begin{haskellcode} + c <- newCollection +\end{haskellcode} + +This creates a new \fw{Collection}. A ``collection'' is group of +widgets, each with its own \fw{FocusGroup}, and the \fw{Collection} +makes it possible to switch between these interfaces. Think of an +e-mail client whose initial interface might be listing the contents of +the inbox; subsequent interactions might change the interface to +present only the selected message on the screen, with different +navigation keystrokes, one of which returns to the inbox interface. +\fw{Collection}s make it easy to switch between such interface modes. +Every \vtyui\ program requires a \fw{Collection}. + +\begin{haskellcode} + addToCollection ui fg +\end{haskellcode} + +This adds the top-level user interface widget, \fw{ui}, to the +\fw{Collection} and sets its focus group to \fw{fg}. This means that +the widgets to receive the user’s focus (and, consequently, input) +will be those in the focus group \fw{fg} and the interface to be +presented will be \fw{ui}. + +\begin{haskellcode} + e `onActivate` \this -> getEditText this >>= + (error . ("You entered: " ++)) +\end{haskellcode} + +This binds an event handler to the ``activation'' of the \fw{Edit} +widget. Activation occurs when the user focuses the \fw{Edit} widget +and presses \fw{Enter}. The handler for this event is an \fw{IO} +action which takes the \fw{Edit} widget itself as its only parameter. +The \fw{getEditText} function gets the current text of the \fw{Edit} +widget, and we use \fw{error} to abort the program and print the text. + +\begin{haskellcode} + runUi c defaultContext +\end{haskellcode} + +This runs the main \vtyui\ event loop with the \fw{Collection} we +created above. We pass a ``default rendering context'' which provides +defaults for the rendering process, such as the default foreground and +background colors to be used for normal and focused widgets, as well +as a “skin” for line-drawing. The main event loop processes input +events from the Vty library and re-draws the interface after calling +any event handlers. It also shuts down Vty in the event of an +exception. + +We've now seen the general structure of a \vtyui\ program: +\begin{itemize} +\item Create and compose widgets, +\item Create a \fw{FocusGroup} and add input-receiving widgets to the + group, +\item Create a \fw{Collection} and add the top-level widget(s) and + \fw{FocusGroup}(s) to the \fw{Collection}, and +\item Invoke the main event loop with the \fw{Collection} and some + default rendering settings. +\end{itemize} diff --git a/doc/ch1/main.tex b/doc/ch1/main.tex new file mode 100644 --- /dev/null +++ b/doc/ch1/main.tex @@ -0,0 +1,25 @@ +\chapter{Introduction} + +The terminal emulator user interface is a good, lightweight +alternative to fully graphical interfaces such as those provided by +GTK, QT, and the Windows and Macintosh OS X operating systems. Such +interfaces are appealing because they can be used easily for remote +administration, and many users prefer them over graphical interfaces +for their responsiveness. + +Historically, terminal interfaces have been notoriously difficult to +program. Libraries such as Ncurses, CDK, Dialog, and Newt have +appeared to aid in this task. + +\vtyui\ provides a “widget” infrastructure for constructing user +interfaces similar to that provided by libraries such as QT and GTK. +In addition to rendering infrastructure, \vtyui\ provides +infrastructure for managing user input events, changes in widget +focus, box layout support, and a flexible API for binding event +handlers to widget events. It is built on the Vty +library,\footnote{Vty on Hackage: + \href{http://hackage.haskell.org/package/vty}{http://hackage.haskell.org/package/vty}} +which provides functionality similar to Ncurses. + +\input{ch1/getting_started} +\input{ch1/api_notes} diff --git a/doc/ch2/collections.tex b/doc/ch2/collections.tex new file mode 100644 --- /dev/null +++ b/doc/ch2/collections.tex @@ -0,0 +1,62 @@ +\section{Collections} +\label{sec:collections} + +Traditional user interfaces present the user with a window for each +task the user needs to accomplish. Since we don't have the option of +presenting multiple "windows" to users of a terminal interface, we +must present the user with one interface at a time. Then, through the +use of event handlers, the application will manage the transition +between these interfaces. + +Consider a text editor program in which we must present these top-level +interfaces in the following order: + +\begin{itemize} +\item The user runs the program and is presented with an interface to + select a file to edit; +\item The user chooses a file to edit and is presented with the + editing interface; +\item After editing, the user chooses to exit and we present a dialog + which asks the user whether to save the file. +\end{itemize} + +All three of these interfaces are separate and should be given the +entire terminal window; unlike other graphical toolkits, \vtyui\ does +not provide a way to "show" or "hide" widgets. Instead, it provides +the notion of a "collection." A \fw{Collection} is a widget which +wraps a set of other widgets and maintains a pointer to the one that +should be displayed at any given time. The application then changes +the current interface by changing the \fw{Collection}'s state. + +But an interface is more than what is presented in the terminal; each +interface should have its own set of user input widgets and its own +notion of focus. Therefore, a \fw{Collection} is a set of interfaces +\textit{and their focus groups}. When we change the state of the +\fw{Collection}, we are really changing both the visual interface as +well as the focus group used to interact with it. + +To create a \fw{Collection}: + +\begin{haskellcode} + c <- newCollection +\end{haskellcode} + +To add an interface and a \fw{FocusGroup} to the \fw{Collection}: + +\begin{haskellcode} + fg <- newFocusGroup + -- Add widgets to focus group fg + ui <- someWidget + changeToW <- addToCollection c ui fg +\end{haskellcode} + +As a convenience, \fw{addToCollection} returns a \fw{MonadIO} action +which, when run, will switch to the specified interface. In the +example above, \fw{changeToW} is an action which will switch to the +interface with \fw{ui} as its top-level widget and \fw{fg} as its +focus group. You can use this action in event handlers that change +your interface state. If you prefer, you can use the +\fw{setCurrentEntry} function instead, which allows you to set the +\fw{Collection}'s interface by number. Use of \fw{setCurrentEntry} is +not recommended, however, since a bad index can cause an exception to +be thrown. diff --git a/doc/ch2/composing.tex b/doc/ch2/composing.tex new file mode 100644 --- /dev/null +++ b/doc/ch2/composing.tex @@ -0,0 +1,79 @@ +\section{Composing Widgets} + +As with any user interface toolkit, \vtyui\ lets you compose your +widgets to create a user interface that is laid out the way you want. +Widgets fall into two basic categories: + +\begin{itemize} +\item ``Basic'' widgets, such as text strings, ASCII decorations + (e.g. vertical and horizontal borders), and space-filling widgets. +\item ``Container'' widgets, which hold other widgets and control how + those widgets are laid out and rendered. Most of these widgets + influence layout; some modify other behaviors. +\end{itemize} + +The most important widgets used in interface layout are the box layout +widgets: + +\begin{haskellcode} + vBox :: Widget a -> Widget b -> IO (Widget (Box a b)) + hBox :: Widget a -> Widget b -> IO (Widget (Box a b)) +\end{haskellcode} + +The \fw{vBox} returns a \fw{Box} widget which lays out its two +children vertically in the order in which they are passed to the +function. The \fw{hBox} function does the same for horizontal layout. +These two widget types will probably be the most common in your +applications. + +\vtyui\ provides some combinators to make \fw{Box}es a bit eaiser to +work with: + +\begin{haskellcode} + (<-->) :: IO (Widget a) -> IO (Widget b) -> IO (Widget (Box a b)) + (<++>) :: IO (Widget a) -> IO (Widget b) -> IO (Widget (Box a b)) +\end{haskellcode} + +These functions are essentially aliases for \fw{vBox} and \fw{hBox}, +respectively, with the important difference being that they take +\fw{IO} arguments. You can use them to create nested boxes as +follows: + +\begin{haskellcode} + mainBox <- (hBox a b) <--> (hBox c d <++> vBox e f) +\end{haskellcode} + +If you already have a reference to another widget, you can merely wrap +it with \fw{return} to use it with these combinators: + +\begin{haskellcode} + box2 <- (return box1) <++> (hBox c d) +\end{haskellcode} + +The box layout widgets do more than merely place their children next +to each other. \fw{Box} widgets determine how to lay their children +out depending on two primary factors: + +\begin{itemize} +\item the amount of terminal space available to the box at the time it + is rendered +\item the size policies of the child widgets +\end{itemize} + +Just as with graphical toolkits, when the terminal is resized, more +space is available to render the interface, so we need to use the +space wisely. To determine how to use it, \vtyui\ requires that the +widgets declare their own policies for how to use the available space. +The default size policy for the \fw{Box} itself is to expand to use +all available space only if that is true for either of its children. +As a result, a \fw{Box} containing two fixed-size widgets will have a +fixed size. For more details on how the \fw{Box} widget is +implemented, see the API documentation. + +Placing text widgets in \fw{Box}es may suffice for most purposes. See +the documentation for space-filling widgets for greater control over +box layout. + +There are many other examples of widgets which influence their +children; we'll see more examples of these in Chapter +\ref{chap:guided_tour}. diff --git a/doc/ch2/event_loop.tex b/doc/ch2/event_loop.tex new file mode 100644 --- /dev/null +++ b/doc/ch2/event_loop.tex @@ -0,0 +1,189 @@ +\section{The \vtyui\ Event Loop} +\label{sec:event_loop} + +\vtyui\ manages the user input event loop for you, and once you have +created and populated a \fw{Collection}, you can invoke the main +\vtyui\ event loop: + +\begin{haskellcode} + runUi c defaultContext +\end{haskellcode} + +The first parameter is the \fw{Collection} you have created; the +second parameter is a \fw{Ren\-der\-Con\-text}. Here we use the +``default'' rendering context provided by the library. The +``rendering context'' provides three key pieces of functionality: + +\begin{itemize} +\item The "skin" to use when rendering ASCII lines, corners, and + intersections +\item The default ``normal'' (unfocused) attribute +\item The default ``focused'' attribute +\item The current ``override'' attribute +\end{itemize} + +\subsection{Skinning} +\label{sec:skinning} + +Some widgets, such as the \fw{Table} widget (see Section +\ref{sec:tables}) and the horizontal and vertical border widgets +\fw{VBorder} and \fw{HBorder} (see Section \ref{sec:borders}), use +line-drawing characters to draw borders between interface elements. +Some terminal emulators are capable of drawing Unicode characters, +which make for nicer-looking line-drawing. Other terminal emulators +work best only with ASCII. The default rendering context uses a +Unicode line-drawing skin, which you can change to any other skin (or +your own) as follows: + +\begin{haskellcode} + runUi c $ defaultContext { skin = asciiSkin } +\end{haskellcode} + +The library provides \fw{Skin}s in the \fw{Skins} module. + +\subsection{Attributes} +\label{sec:attributes} + +An attribute may consist of one or more settings of foreground and +background color and text style, such as underline or blink. The +default attributes specified in the \fw{Render\-Context} control how +widgets appear. + +Every widget has the ability to store its own normal and focused +attributes. When widgets are rendered, they use these attributes; if +they are not set, the widgets default to using those specified by the +rendering context. The only exception is the ``override'' attribute. +Instead of ``falling back'' to this attribute, the presence of this +attribute reuqires widgets to use it. For example, this attribute is +used in the \fw{List} widget so that the currently-selected list item +can be highlighted, which requires the \fw{List} to override the +item's default attribute configuration. + +Widgets provide an API for setting these attributes using the +\fw{Has\-Normal\-Attr} and \fw{Has\-Focus\-Attr} type classes. The +reason we use type classes to provide this API is so that third-party +widgets may also provide this functionality. The API is defined in +the \fw{Core} module and is as follows: + +\begin{haskellcode} + setNormalAttribute w attr + setFocusAttribute w attr +\end{haskellcode} + +Convenience combinators also exist: + +\begin{haskellcode} + w <- someWidget + >>= withNormalAttribute attr + >>= withFocusAttribute attr +\end{haskellcode} + +The \fw{attr} value is a Vty attribute. A Vty attribute may provide +any (but not necessarily all!) of the settings that make up an +attribute; any setting not specified (e.g. background color) can fall +back to the default. As a result, the attribute of a widget is the +\textit{combination} of its attribute and the attribute from the +rendering context. The widget's settings will take precedence, but +any setting not provided will default to the rendering context. + +Consider this example: + +\begin{haskellcode} + w <- someWidget + setNormalAttribute w (fgColor white) + runUi c $ defaultContext { normalAttr = yellow `on` blue } +\end{haskellcode} + +In this example, the widget \fw{w} will use a normal attribute of +white on a blue background, since it specified only a foreground color +as its normal attribute. This kind of precedence facilitates visual +consistency across your entire interface. + +In addition, container widgets are designed to pass their normal and +focused attributes onto their children during the rendering process; +this way, unless a child specifies a default with +\fw{setNormalAttribute} or similar, it uses its parent's attributes. +Again, this facilitates consistency across the interface while only +requiring the you to specify attributes where you want to deviate from +the default. + +You can create attributes with varying levels of specificity by using +the \vtyui\ API: + +\begin{tabular}{|l|l|} \hline +Expression & Resulting attribute \\ \hline +\fw{fgColor blue} & foreground only \\ \hline +\fw{bgColor blue} & background only \\ \hline +\fw{style underline} & style only \\ \hline +\fw{blue `on` red} & foreground and background \\ \hline +\fw{someAttr `withStyle` underline} & adding a style \\ \hline +\end{tabular} + +The Vty \fw{def\_attr} value's default configuration is used as a +basis for all partially-specified attributes. The functions described +above are defined in the \fw{Util} module. + +\subsection{\vtyui\ and Concurrency} +\label{sec:concurrency} + +So far we have only seen programs which modify widget state when user +input events occur. Such changes in widget state are safe, because +they are triggered by the \vtyui\ event loop.\footnote{``Unsafe'' + updates are those that are not guaranteed to be reflected in the + most-recently-rendered interface.} However, your program will more +than likely need to trigger some widget state changes due to other +external events -- such as network events -- and \vtyui\ provides a +mechanism for doing this in a safe way. + +\vtyui\ provides a function in the \fw{Core} module called +\fw{schedule} which takes an \fw{IO} action and ``schedules'' it to be +run by the main event loop. It will be run as soon as possible, i.e., +once the program control flow has returned to the event loop. Since +the scheduled action will be run by the event loop, it's important +that the action not take very long; if it's important to block (e.g., +by calling \fw{Control.Concurrent.threadDelay}), you should do that in +a thread and only call \fw{schedule} when you have work to do. + +Consider this example, in which a text widget called \fw{timeText} +gets updated with the current time every second: + +\begin{haskellcode} + forkIO $ + forever $ do + schedule $ do + t <- getCurrentTime + setText timeText $ + formatTime defaultTimeLocale rfc822DateFormat t + threadDelay 1000000 +\end{haskellcode} + +In this example the blocking occurs outside of the scheduled code, and +only when we have an update for the clock display do we schedule an +action to run. + +Some built-in widgets will almost always be used in this way; for an +example, take a look at the \fw{ProgressBar} widget in the +\fw{ProgressBar} module (see Section \ref{sec:progress_bars}). + +\subsection{Managing Your Own State} + +If your applications have their own state management needs, then that +state management can be done in parallel with the \vtyui\ event loop +with proper use of \fw{schedule}. + +A typical design for applications using \vtyui\ is: + +\begin{itemize} +\item The application defines its own state type, call it + \fw{AppState}. +\item The \fw{AppState} type has fields for the various widgets that + need to be mutated over the course of the application's execution; + for example, lists, progress bars, radio buttons, check boxes, edit + widgets, etc. +\item Various event handlers are set up on these and other widgets. +\item The application spawns one or more threads to manage events from + external sources, and when these events occur, actions are scheduled + with \fw{schedule} to update the interface state accordingly. +\item The main event loop is executed and control is passed to the + library. +\end{itemize} diff --git a/doc/ch2/focus_groups.tex b/doc/ch2/focus_groups.tex new file mode 100644 --- /dev/null +++ b/doc/ch2/focus_groups.tex @@ -0,0 +1,149 @@ +\section{Focus Groups and Focus Changes} +\label{sec:focus} + +Graphical interfaces allow the user to change focus between all of the +primary interface input elements, usually with the Tab key. The same +is true in \vtyui, except that because any widget can accept events -- +and because you decide which widgets are ``focusable'' -- the library +cannot automatically determine which widgets should get the focus, or +the order in which focus should be received. As a result, +\vtyui\ provides a type called a "focus group." + +A focus group is just an ordered sequence of widgets that should get the +user's focus as the Tab key is pressed. Widgets receive focus in the +order in which they are added to the group, and the first widget to be +added automatically gets the focus when it is added. + +Creating a focus group is simple: + +\begin{haskellcode} + fg <- newFocusGroup +\end{haskellcode} + +Adding widgets to focus groups is also straightforward: + +\begin{haskellcode} + w <- someWidget + addToFocusGroup fg w +\end{haskellcode} + +A widget's ``focused behavior'' depends entirely on the widget's +implementation. Some widgets, when focused, provide a text cursor; +others merely change foreground and background color. In any case, +the widgets that the user can interact with should be in the +interface's focus group. + +Once widgets are added to the focus group, you won't have to manage +anything else; the Tab key event is intercepted by the \fw{FocusGroup} +itself, and user input events are passed to the focused widget until +the focus is changed. + +If, for some reason, you would like to be notified when a widget +receives or loses focus, you may register event handlers for these +events on any widget: + +\begin{haskellcode} + w <- someWidget + w `onGainFocus` \this -> ... + w `onLoseFocus` \this -> ... +\end{haskellcode} + +In both cases above, the \fw{this} parameter to each event handler is +just the widget to which the event handler is being attached (in this +case, \fw{w}). Many event handlers follow this pattern. + +\subsection{Top-Level Key Event Handlers} + +All user input is handled via a \fw{FocusGroup}; the focus state of +the group indicates which widget will receive user input events. +However, \fw{FocusGroup}s are widgets, too! Although they cannot be +rendered, they support the same key handler interface as other +widgets. This is how we create "top-level" key event handlers for the +entire interface. For example, if you want to register a handler for +a "quit" key such as \fw{'q'}, the focus group itself is where this +key event handler belongs. This is because focus groups always try to +handle key events first, and only pass those events onto the focused +widget if the \fw{FocusGroup} has no matching handler. + +\begin{haskellcode} + fg <- newFocusGroup + fg `onKeyPressed` \_ key _ -> + if key == KASCII 'q' then + exitSuccess else return False +\end{haskellcode} + +\subsection{Container Widgets and Input Events} +\label{sec:containers_and_input} + +Most of the time you will probably end up adding key event handlers +directly to interactive widgets, but it may be convenient to wrap +those widgets in containers that affect their behavior. For example, +in the demonstration in Section \ref{sec:gettingStarted}, we used then +\fw{centered} function to center an edit widget. The result was a +\fw{Centered} widget, which is one of the many built-in container +widget types. This type of widget ``relays'' user input events and +focus events to the widget it contains. This means you can add key +and focus event handlers to the \fw{Centered} widget and they will be +passed on to the child widget for handling. Most container widgets +are implemented this way; when in doubt about event relaying behavior, +consult the API documentation. Relaying of events is accomplished +with the following functions, defined in the \fw{Core} module: + +\begin{itemize} +\item \fw{relayFocusEvents} -- relays focus events from one widget to + another. For example: \fw{wRef `relayFocusEvents` someWidget}. + When \fw{wRef} becomes focused, it will focus \fw{someWidget}. +\item \fw{relayKeyEvents} -- relays keyboard input events from one + widget to another. For example: \fw{wRef `relayKeyEvents` + someWidget}. When \fw{wRef} becomes unfocused, it will unfocus + \fw{someWidget}. +\end{itemize} + +As we saw above, only focused widgets will ever be asked to process +input events; this means that if you add event handlers to a container +such as \fw{Centered}, you'll need to add that widget -- not its child +-- to the \fw{FocusGroup}. + +You might wonder why this is useful. Consider a situation in which +you want to add some padding to an input widget, such as an \fw{Edit} +widget, but when the \fw{Edit} widget is focused you want to highlight +the padding, too, to make them appear as a single widget. Since +padding widgets (see Section \ref{sec:padding}) relay events to their +children, you could focus the padding widget and the edit widget would +automatically receive the focus as well as user input events. This +kind of focus and event ``inheritance'' makes it possible to create +new, composite widgets in a flexible way, while getting the desired +visual results. + +\subsection{Merging Focus Groups} +\label{sec:merging_focus_groups} + +Some widgets, such as the ``dialog'' widget (\fw{Dialog}, see Section +\ref{sec:dialogs}), are composed of a number of input widgets already; +widgets like \fw{Dialog} must create their own \fw{Focus\-Group}s to +provide coherent focus behavior, and they will return them to you when +they are created. In order to integrate these focus groups into your +application, you must merge them with your own focus group. + +For example, consider the ``directory browser'' widget +(\fw{DirBrowser}, see Section \ref{sec:dirbrowser}). You might want +to place this alongside other widgets that should also accept input. +When you create the \fw{DirBrowser} widget, you will get a reference +to the widget and a reference to its \fw{FocusGroup}: + +\begin{haskellcode} + (browser, fg1) <- newDirBrowser defaultBrowserSkin + + fg2 <- newFocusGroup + -- Add my own widgets to fg2 + + merged <- mergeFocusGroups fg1 fg2 +\end{haskellcode} + +The \fw{mergeFocusGroups} function will merge the two focus groups and +preserve the order of the widgets, such that widgets in the first +group will come before widgets in the second group in the new group's +focus ordering. The merged group should then be passed to the rest of +the setup process that we introduced in Section +\ref{sec:gettingStarted}; we'll go into more detail on that in the +next section. diff --git a/doc/ch2/handling_user_input.tex b/doc/ch2/handling_user_input.tex new file mode 100644 --- /dev/null +++ b/doc/ch2/handling_user_input.tex @@ -0,0 +1,46 @@ +\section{Handling User Input} + +Many widgets in \vtyui\ can accept user input. A widget can accept +user input if (1) it has one or more \textit{key event handlers} +attached to it and (2) if it currently has the \textit{focus}. The +concept of focus in \vtyui\ works the same as in other user interface +toolkits: essentially, only one widget has the focus and any user +input is passed to that widget for handling. + +Key event handlers can be added to any \fw{Widget a} as follows: + +\begin{haskellcode} + w <- someWidget + w `onKeyPressed` \this key modifiers -> do + ... + return False +\end{haskellcode} + +The handler must return \fw{IO Bool}; \fw{True} indicates that the +handler processed the key event and took action and \fw{False} +indicates that the handler declined to handle the event. The event +handler is passed the keystoke itself along with any modifier keys +detected by the underlying Vty input processing. + +Key event handlers are invoked in the order in which they are added to +the widget. In the following example, the first handler will decline +the \fw{'q'} key event but the second one will process it: + +\begin{haskellcode} + w `onKeyPressed` \_ key _ -> + if key == KASCII 'f' then + (launchTheMissiles >> return True) else + return False + + w `onKeyPressed` \_ key _ -> + if key == KASCII 'q' then + exitSuccess else return False +\end{haskellcode} + +This functionality allows any widget to have its own "default" input +event handling while still allowing you to add custom input event +handling. + +Although any widget -- even a basic text widget -- can accept input +events in this way, the events will only reach the widget if it has the +focus. The way we manage focus is with "focus groups." diff --git a/doc/ch2/main.tex b/doc/ch2/main.tex new file mode 100644 --- /dev/null +++ b/doc/ch2/main.tex @@ -0,0 +1,11 @@ +\chapter{Building Applications With \vtyui} + +This chapter will introduce various design aspects of the library and +provide you with the tools you'll need to build your own applications +with \vtyui. + +\input{ch2/composing} +\input{ch2/handling_user_input} +\input{ch2/focus_groups} +\input{ch2/collections} +\input{ch2/event_loop} diff --git a/doc/ch3/cursor_positioning.tex b/doc/ch3/cursor_positioning.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/cursor_positioning.tex @@ -0,0 +1,34 @@ +\section{Cursor Positioning} +\label{sec:cursor_positioning} + +Once a widget is properly positioned, the widget can display a cursor. +This is especially useful for edit widgets, since the user needs to +know the cursor position. The \fw{Core} module provides a top-level +function to accomplish this called \fw{getCursorPosition}; this +function calls the \fw{WidgetImpl} type's \fw{getCursorPosition\_} +function. + +The \fw{getCursorPosition\_} function returns \fw{Maybe + DisplayRegion}. A return value of \fw{Nothing} indicates that the +widget does not want to show a cursor, so when it gains focus, no +cursor will be displayed. Otherwise, positioning the cursor at row +\fw{r} and column \fw{c} is accomplished by returning \fw{Just + (DisplayRegion r c)}. The cursor is then shown at that location by +the event loop. + +Typically, the position of the cursor is computed as an offset to the +widget's current position. In the \fw{Wrapper} widget example in +Section \ref{sec:deferring} we deferred to the child widget to control +the cursor, but we might instead specify our own position: + +\begin{haskellcode} + getCursorPosition_ = \this -> do + (Wrapper child) <- getState this + childCursor <- getCursorPosition child + case childCursor of + Nothing -> return Nothing + Just pos -> return $ Just $ pos `plusWidth` 1 `plusHeight` 1 +\end{haskellcode} + +Although contrived, this example shows how we can return a new cursor +position based on the child widget's cursor position. diff --git a/doc/ch3/deferring_to_children.tex b/doc/ch3/deferring_to_children.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/deferring_to_children.tex @@ -0,0 +1,68 @@ +\section{Deferring to Child Widgets} +\label{sec:deferring} + +Widget-wrapping widget types are common in \vtyui, since we use this +technique to influence rendering and other behaviors. As a result, +when implementing a wrapper widget it is important to decide which +behaviors should be deferred to the child widget and which behaviors +should be overridden. + +In this section we'll create a wrapper widget type called \fw{Wrapper} +and we'll implement all of its behaviors to illustrate how the +behaviors can be deferred in each case. + +We'll start with the type. + +\begin{haskellcode} + data Wrapper a = Wrapper (Widget a) +\end{haskellcode} + +Then the implementation of the constructor:\footnote{This widget + implementation uses the ``relaying'' functions we described in + Section \ref{sec:containers_and_input}.} + +\begin{haskellcode} + newWrapper :: (MonadIO m) => Widget a -> m (Widget (Wrapper a)) + newWrapper child = do + wRef <- newWidget $ \w -> + w { state = Wrapper child + , growHorizontal_ = growHorizontal child + , growVertical_ = growVertical child + , setCurrentPosition_ = + \_ pos = setCurrentPosition child pos + , getCursorPosition_ = + const $ getCursorPosition child + , render_ = + \_ sz ctx = do + render child sz ctx + } + + wRef `relayFocusEvents` child + wRef `relayKeyEvents` child + return wRef +\end{haskellcode} + +This demonstration highlights some important features of container +widget implementations: + +\begin{itemize} +\item The state type of the wrapped widget, \fw{a}, is preserved in + the type of the wrapper widget itself, \fw{Wrapper a}. +\item We referred directly to \fw{child} instead of using + \fw{getState} in all of the functions; the reason is because we + don't care about allowing the child to be replaced with a different + widget at a later time. If that is something you want to support, + then you \textit{must} use \fw{getState} to ensure that you have the + latest version of the widget's state and, as a result, the correct + child widget reference. +\item We defer all behaviors to the child: growth policy, rendering, + positioning, cursor behavior, focus events, and key events. Most + container widgets defer most of these things. +\end{itemize} + +In some cases -- such as with \fw{Centered} widgets or anything that +adds padding -- the growth policies will need to be changed to reflect +how the final result should be laid out. In those cases, it is +sufficient to provide an implementation for the growth policy +functions that returns the desired value rather than calling that of +the child widget. diff --git a/doc/ch3/growth_policy_functions.tex b/doc/ch3/growth_policy_functions.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/growth_policy_functions.tex @@ -0,0 +1,66 @@ +\section{Growth Policy Functions} +\label{sec:growth_policy_functions} + +In order to lay widgets out in way that makes the best use of the +available terminal space, we need them to give us hints about how they +use space. In this regard, widgets fall into two basic categories: + +\begin{itemize} +\item ``Fixed-size'' widgets which have the same size regardless of + the amount of available space, and +\item ``Variable-size'' widgets which use all available space. +\end{itemize} + +An example of a ``fixed-size'' widget is a text widget: the string +``\fw{foobar}'' will always require only one row and six columns' +worth of space. We could also render such a widget in a much bigger +space -- an entire terminal window, say -- but it would look the same; +there would still be plenty of room for other things in the interface. +Such a widget does not ``grow'' with the available space. + +An example of a ``variable-size'' widget is one which centers a child +widget vertically and horizontally in the terminal. Such a widget +will pad its child widget so that it is always centered, and this +behavior depends on how much space is available. For example, in a +100x100 terminal, the string ``\fw{foobar}'' would need different +padding to remain centered than it would require in a 50x50 terminal. +As a result, we say that the centering widget ``grows'' with available +space. + +The \fw{WidgetImpl a} type defines the following functions to provide +these hints: + +\begin{itemize} +\item \fw{growHorizontal\_ ::\ a -> IO Bool} +\item \fw{growVertical\_ ::\ a -> IO Bool} +\end{itemize} + +These functions should return \fw{True} when the widget in question +``grows'' as described above, and \fw{False} otherwise. These hints +may be used by parent widgets to make layout decisions; concrete +examples of such widgets are the \fw{Box} and \fw{Centered} widget +types. + +In situations where your widget wraps another -- as with the \fw{Box} +and \fw{Centered} types -- it is \textit{strongly} recommended that +you defer to the child widgets for these policy values \textit{unless} +you have a good reason to override them. The \fw{Centered} widget is +a good example of this: it overrides the growth policy of its child so +that it grows in both dimensions, even though its child may not. But +the \fw{Box} widget explicitly defers to its children to determine its +growth policy, since it is only responsible for layout and does not +add anything to the interface. + +An example of a \fw{growHorizontal\_} implementation which defers to a +child widget is as follows: + +\begin{haskellcode} + -- Assume getChildWidget gets the child widget reference + growHorizontal_ = growHorizontal . getChildWidget +\end{haskellcode} + +Notice that we call the top-level function, \fw{growHorizontal}, on +the child widget; it does the job of dereferencing the widget and +calling its \fw{growHorizontal\_} function. This is another example +of the API convention we mentioned in Section +\ref{sec:widgetimpl_api}. diff --git a/doc/ch3/implementing_composite_widgets.tex b/doc/ch3/implementing_composite_widgets.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/implementing_composite_widgets.tex @@ -0,0 +1,128 @@ +\section{Composite Widgets} + +So far we have looked at single-purpose widgets which use the +\fw{Widget} type directly. However, embedding widget state in the +\fw{Widget} type is not always appropriate or straightforward for more +complex, composite widgets. + +The \vtyui\ library provides some ``widgets'' which don't fit this +pattern: \fw{Dialog} and \fw{DirBrowser} are two examples. +Furthermore, as the base set of widgets provided by the library +becomes richer, fewer and fewer widgets should be implemented using +the basic \fw{Widget} framework. + +These composite widgets are actually entire interfaces, complete with +multiple focusable widgets and focus groups. These widgets don't take +the form of \fw{Widget Dialog} or \fw{Widget DirBrowser}; they +\textit{could} be implemented that way, but we'd find that many of the +\fw{WidgetImpl} functions would end up deferring to their child +widgets anyway, and their \fw{render\_} implementations would be +cumbersome at best. + +Instead, we invert the widget organization: we create a type (e.g., +\fw{Dialog}) which contains the actual widget(s) to be rendered, as +well as other book-keeping internals, and we return that from our +constructor. This makes it easier to implement such widgets since we +are less concerned with their inner workings and more concerned with +returning something high-level that has the right behaviors. + +The pattern we use in these situations is to write a constructor which +does all of the widget creation, layout, and event handler +registration, and returns the concrete type of the interface along +with a \fw{FocusGroup} which the caller can use to integrate the +interface into an application. + +For example: suppose we want to create a ``phone number input'' widget +-- \fw{PhoneInput}, say -- which will allow users to input phone +numbers. The \fw{PhoneInput} will have three \fw{Edit} widgets and +will manage tabbing between them and might even do such things as data +validation on the input. Here's a suggestive example for how we might +implement such a thing without going to all the trouble of +implementing \fw{WidgetImpl}'s interface. First we provide the types: + +\begin{haskellcode} + data PhoneNumber = PhoneNumber String String String + deriving (Show) + + -- This type isn't pretty, but we have to specify the type + -- of the complete interface. Initially you can let the + -- compiler tell you what it is. + type T = Box (Box + (Box (Box (HFixed Edit) FormattedText) (HFixed Edit)) + FormattedText) (HFixed Edit) + + data PhoneInput = + PhoneInput { phoneInputWidget :: Widget T + , edit1 :: Widget Edit + , edit2 :: Widget Edit + , edit3 :: Widget Edit + , activateHandlers :: Handlers PhoneNumber + } +\end{haskellcode} + +Then, we provide the constructor: + +% Let this block span a page boundary since it's so big that it's +% likely, and we don't want to bump it down unless it looks good. :) +\begin{haskellcode*}{samepage=false} + newPhoneInput :: (MonadIO m) => m (PhoneInput, Widget FocusGroup) + newPhoneInput = do + ahs <- newHandlers + e1 <- editWidget + e2 <- editWidget + e3 <- editWidget + + ui <- (hFixed 4 e1) <++> + (plainText "-") <++> + (hFixed 4 e2) <++> + (plainText "-") <++> + (hFixed 5 e3) + + setEditMaxLength e1 3 + setEditMaxLength e2 3 + setEditMaxLength e3 4 + + e1 `onChange` \s -> when (length s == 3) $ focus e2 + e2 `onChange` \s -> when (length s == 3) $ focus e3 + + let w = PhoneInput ui e1 e2 e3 ahs + doFireEvent = const $ do + num <- mkPhoneNumber + fireEvent w (return . activateHandlers) num + + mkPhoneNumber = do + s1 <- getEditText e1 + s2 <- getEditText e2 + s3 <- getEditText e3 + return $ PhoneNumber s1 s2 s3 + + e1 `onActivate` doFireEvent + e2 `onActivate` doFireEvent + e3 `onActivate` doFireEvent + + fg <- newFocusGroup + mapM_ (addToFocusGroup fg) [e1, e2, e3] + return (w, fg) +\end{haskellcode*} + +Then we provide a function to register phone number handlers: + +\begin{haskellcode} + onPhoneInputActivate :: (MonadIO m) => PhoneInput + -> (PhoneNumber -> IO ()) -> m () + onPhoneInputActivate input handler = + addHandler (return . activateHandlers) input handler +\end{haskellcode} + +When the user presses \fw{Enter} in one of the phone number input +widgets, thus ``activating'' it, we will invoke all phone number input +handlers with a \fw{PhoneNumber} value.\footnote{Assume that we would + also do some kind of validation and decide whether to call the + handlers accordingly. We might even consider supporting ``error'' + event handlers for the widget to report validation errors to be + displayed elsewhere in the interface!} + +In the calling environment, the caller can then add the +\fw{phoneInputWidget} to the interface and merge the returned +\fw{FocusGroup} as described in Section +\ref{sec:merging_focus_groups}. diff --git a/doc/ch3/implementing_event_handlers.tex b/doc/ch3/implementing_event_handlers.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/implementing_event_handlers.tex @@ -0,0 +1,113 @@ +\section{Handling Events} +\label{sec:event_handlers} + +An interface is truly interactive only if we can express the +relationship between various events in the interface. User input and +network events may affect the user interface, but we also need to be +define how the interface components interact with each other. +\vtyui\ provides a mechanism to address this called the \fw{Handlers} +type, defined in the \fw{Events} module. + +For any given widget type, we must decide what events can occur as a +result of the widget's state change. For each type of event, we must +decide what sort of data we should pass to handlers of this event so +they can take an appropriate action. + +Imagine that you've implemented a ``temperature monitor'' widget, and +you want to be notified whenever the temperature changes so you can +update other parts of your interface. In that case, the event data is +a type containing the new temperature: + +\begin{haskellcode} + data TemperatureEvent = Temp Int +\end{haskellcode} + +In your widget type definition, you'll need a place to store the event +handlers for this temperature change event: + +\begin{haskellcode} + data TempMonitor = + TempMonitor { tempChangeHandlers :: Handlers TemperatureEvent + } +\end{haskellcode} + +Notice that we use the event type as the type parameter to +\fw{Handlers}; this indicates that we want to store a collection of +handler functions which take an argument of type +\fw{TemperatureEvent}. The \fw{Handlers a} type is just an alias for +\fw{IORef [a -> IO ()]}. + +Once we've defined our storage type, we need to update our widget +constructor to construct a \fw{Handlers} list: + +\begin{haskellcode} + newTempMonitor :: (MonadIO m) => m (Widget TempMonitor) + newTempMonitor = do + handlers <- newHandlers + wRef <- newWidget $ \w -> + w { state = TempMonitor { tempChangeHandlers = handlers + } + } + + return wRef +\end{haskellcode} + +Now we have a place to store the handlers, a model for the event data +itself, and an updated constructor. Next, we need a nice API to +register new event handlers. The \fw{vty-ui} convention is to use +functions prefixed with ``on'', such as \fw{onGainFocus} and +\fw{onActivate}. This convention makes it easy to write readable +infix event handler registration functions. In the temperature +monitor case, we might write something like this: + +\begin{haskellcode} + onTemperatureChange :: (MonadIO m) => Widget TempMonitor + -> (TemperatureEvent -> IO ()) + -> m () + onTemperatureChange wRef handler = + addHandler (tempChangeHandlers <~~) wRef handler +\end{haskellcode} + +We've introduced a new operator here, \fw{<\string~\string~}. This +operator takes any \fw{Widget a} and a function on its state type, +\fw{a -> b}, and runs the function and returns the value, \fw{b}, +inside calling monad. \fw{addHandler} needs a value of type +\fw{Handlers TemperatureEvent}, and to get that we must use +\fw{<\string~\string~}. + +The \fw{addHandler} function takes a \fw{Handlers a} and a handler of +type \fw{a -> IO ()} and adds it to the \fw{Handlers} list. + +Here is a bogus but valid demonstration of this new function: + +\begin{haskellcode} + let maxTemp = 100 + t <- newTempMonitor + t `onTemperatureChange` \(Temp newTemp) -> + when (newTemp > maxTemp) $ error "It's too hot!" +\end{haskellcode} + +The last thing it do is to actually ``fire'' the event that these +handlers will handle; assuming the monitor widget has a +\fw{setTemperature} function and some internal state to store the +temperature, that function would create the \fw{TemperatureEvent} and +invoke the handlers as follows: + +\begin{haskellcode} + setTemperature :: (MonadIO m) => Widget TempMonitor -> Int -> m () + setTemperature wRef newTemp = do + -- Set the internal widget state. + -- ... + -- Then invoke the handlers: + fireEvent wRef (tempChangeHandlers <~~) (TemperatureEvent newTemp) +\end{haskellcode} + +Just as with \fw{addHandler}, we pass a handler list lookup function +to \fw{fireEvent}. We also pass it an event value which will be +passed to all of the registered handler functions. + +The functions \fw{newHandlers}, \fw{addHandler}, and \fw{fireEvent} +are defined along with the \fw{Handlers} type in the \fw{Events} +module. The widget state projection function \fw{<\string~\string~} +is defined in the \fw{Core} module along with its \fw{WidgetImpl} +state projection counterpart, \fw{<\string~}. diff --git a/doc/ch3/main.tex b/doc/ch3/main.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/main.tex @@ -0,0 +1,17 @@ +\chapter{Implementing Your Own Widgets} + +While the built-in widgets may prove sufficient in most cases, sooner +or later you'll probably need to implement your own. This chapter +describes the API you'll need to implement to do this, as well as +design and implementation considerations relevant to building custom +widgets correctly. + +\input{ch3/new_widget_type} +\input{ch3/widgetimpl_api} +\input{ch3/rendering} +\input{ch3/growth_policy_functions} +\input{ch3/deferring_to_children} +\input{ch3/widget_positioning} +\input{ch3/cursor_positioning} +\input{ch3/implementing_event_handlers} +\input{ch3/implementing_composite_widgets} diff --git a/doc/ch3/new_widget_type.tex b/doc/ch3/new_widget_type.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/new_widget_type.tex @@ -0,0 +1,160 @@ +\section{Creating a New Widget Type} +\label{sec:new_widget_type} + +The first step in creating a custom widget is deciding what kind of +state the widget will store. This decision is based on what behaviors +the widget can have and it determines what the widget's API will be. + +As an example, consider a widget that displays a numeric counter. The +widget state will be the value of the counter. We'll start with the +following state type:\footnote{You might wonder why we don't just use + \fw{Int}; the reason is because that's too general. Other widgets + might represent the temperature with an \fw{Int}, and then your + counter API functions -- taking a widget of type \fw{Widget Int} -- + would work on their widgets, which is probably not what you want!} + +\begin{haskellcode} + data Counter = Counter Int +\end{haskellcode} + +The next step is to write a widget constructor function. This +function will return a value of type \fw{Widget Counter}, which +indicates that it is a \fw{Widget} with state type \fw{Counter}. +We'll allow the constructor to take the counter's initial value. +Here's what the function will look like in full: + +\begin{haskellcode} + newCounter :: (MonadIO m) => Int -> m (Widget Counter) + newCounter initialValue = do + wRef <- newWidget $ \w -> + w { state = Counter initialValue + , render_ = + \this size ctx -> do + (Counter v) <- getState this + return $ string (getNormalAttr ctx) (show v) + } +\end{haskellcode} + +Now we have a constructor for a \fw{Counter} widget. Let's go through +the code: + +\begin{haskellcode} + wRef <- newWidget $ \w -> ... +\end{haskellcode} + +The \fw{Core} module's \fw{newWidget} function creates a new +\fw{IORef} wrapping a \fw{WidgetImpl a}. The \fw{WidgetImpl} type is +where all of the widget logic is actually implemented. You implement +this logic by overriding the fields of the \fw{WidgetImpl} type, such +as \fw{render\_} and \fw{state}. We call \fw{newWidget}'s result +\fw{wRef} because it is a reference to a widget object, and this helps +distinguish it from the actual widget data in the next step. + +The \fw{newWidget} function takes a function \fw{WidgetImpl a -> + WidgetImpl a} and updates the widget implementation contained in the +\fw{IORef}. We use this to specify the behavior of the widget beyond +the defaults, which are specified in the \fw{newWidget} function. + +\begin{haskellcode} + state = Counter initialValue +\end{haskellcode} + +Here we set the inital value of the counter and create the +\fw{Counter} state and store it in the \fw{WidgetImpl}. We'll +reference this state later on in the rendering code and in any API +functions that we want to implement to mutate it. + +\begin{haskellcode} + render_ = + \this size ctx -> do + (Counter v) <- getState this + let s = show v + width = fromEnum $ region_width size - length s + truncated = take width s + return $ string (getNormalAttr ctx) truncated +\end{haskellcode} + +This actually does the job of rendering the counter value into a form +that can be displayed in the terminal. The type of \fw{render\_} is +\fw{Widget a -> DisplayRegion -> RenderContext -> IO Image}. The +types are as follows: + +\begin{itemize} +\item \fw{Widget a} - the widget being rendered, i.e., the \fw{Widget + Counter} reference. This is passed to provide access to the + widget's state which will be used to render it. +\item \fw{DisplayRegion} - the size of the display region into which + the widget should fit, measured in rows and columns. The \fw{Image} + returned by \fw{render\_} should \textit{never} be larger than this + region, or the rendering process will raise an exception. The + reason is because if it were to violate the specified size, then the + assumptions made by any other widgets about layout would fail, and + the interface would become garbled in the terminal. In addition, + widget sizes are used to compute widget positions, so sizes must be + accurate. + + A widget may render to an \fw{Image} \textit{smaller} than the + specified size; many do. +\item \fw{RenderContext} - the rendering context passed to \fw{runUi} + as explained in Section \ref{sec:event_loop}. In the \fw{render\_} + function, we use this to determine which screen attributes to use. + We don't care about supporting a focused behavior in our + \fw{Counter} widgets, so we just look at the ``normal'' attribute. +\item \fw{Image} - this is the type of Vty ``images'' that can be + composed into a final terminal representation. All widgets must be + converted to this type during the rendering process to be composed + into the final result. +\end{itemize} + +The implementation of the \fw{render\_} function is as follows: + +\begin{haskellcode} + (Counter v) <- getState this +\end{haskellcode} + +The \fw{getState} function takes a \fw{Widget a} and returns its +\fw{state} field. In this case, it returns the \fw{Counter} value. + +\begin{haskellcode} + let s = show v + width = fromEnum $ region_width size - length s + truncated = take width s +\end{haskellcode} + +To ensure that the \fw{Image} we generate does not exceed \fw{size} as +described above, we use the width of the region to limit how many +characters we take from the string representation of the counter. + +\begin{haskellcode} + return $ string (getNormalAttr ctx) truncated +\end{haskellcode} + +The \fw{string} function is a Vty library function which takes an +attribute (\fw{Attr}) and a \fw{String} and returns an \fw{Image}. +The \fw{getNormalAttr} function returns the normal attribute from the +\fw{Render\-Context}, merged with the ``override'' attribute from the +\fw{Render\-Context}, if it is set. For more information on the +override attribute, see Section \vref{sec:attributes}. + +This concludes the basic implementation requirements for a new widget +type; to make it useful, we'll need to add some functions to manage +its state: + +\begin{haskellcode} + setCounterValue :: (MonadIO m) => Widget Counter -> Int -> m () + setCounterValue wRef val = + updateWidgetState wRef $ const $ Counter val + + getCounterValue :: (MonadIO m) => Widget Counter -> m Int + getCounterValue wRef = do + Counter val <- getState wRef + return val +\end{haskellcode} + +The \fw{setCounterValue} function takes a \fw{Counter} widget and sets +its \fw{state} to a new counter value. The \fw{updateWidgetState} +function takes a \fw{Widget a} and a state transformation function and +updates the \fw{state} field of the widget. The \fw{getCounterValue} +function just reads the state and returns the counter's value. Now +you could write a program using these functions to create, manipulate, +and display the counter. diff --git a/doc/ch3/rendering.tex b/doc/ch3/rendering.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/rendering.tex @@ -0,0 +1,62 @@ +\section{Rendering} + +The \fw{render\_} function is responsible for generating a visual +representation of the widget based on various factors, including: + +\begin{itemize} +\item The focus state of the widget +\item The available space specified by the \fw{size} parameter to the + \fw{render\_} function +\item The widget's own internal state in its \fw{state} field +\item All child widgets +\item Attributes stored in the widget as well as those provided in the + \fw{RenderContext} +\end{itemize} + +This involves constructing \fw{Image}s using the Vty library's +primitives. Some primitives include: + +\begin{itemize} +\item \fw{string} -- Creates an image from a string using the + specified attribute. +\item \fw{char} -- Creates an image from a character using the + specified attribute. +\item \fw{char\_fill} -- Creates an image with the specified width and + height, filled with the specified character and attribute. +\item \fw{<->} -- Vertical concatenation of images. +\item \fw{<|>} -- Horizontal concatenation of images. +\end{itemize} + +While these functions should be sufficient to render most widgets, if +your widget wraps other widgets, you'll have to use the top-level +\fw{render} function provided by the \fw{Core} module. It has the +following type: + +\begin{haskellcode} + render :: Widget a -> DisplayRegion -> RenderContext -> IO Image +\end{haskellcode} + +This function looks a lot like the \fw{render\_} function in the +\fw{WidgetImpl} type, and that's intentional; the difference is that +\fw{render} \textit{calls} \fw{render\_} on the widget that is passed +to it, and it does some other important things: + +\begin{itemize} +\item It gets the normal and focus attributes stored in the widget, if + any, and merges them into the \fw{RenderContext}. This means that + the \fw{render\_} function doesn't have to specifically look those + attributes up; it just needs to use whatever is in the context. +\item It invokes the \fw{render\_} function to get the resulting + \fw{Image}. +\item It measures the size of the resulting \fw{Image} against the + \fw{DisplayRegion} given to it and raises an exception (of type + \fw{RenderError}) if the image is too large. +\item If the size check passes, it calls \fw{setCurrentSize} on the + widget with the size of the generated \fw{Image}. +\end{itemize} + +All of this book-keeping is vital to ensuring that the rendering +process works correctly; as a result, whenever you are rendering other +widgets inside your \fw{render\_} implementation, you \textit{must} +use \fw{render} to do it instead of extracting and calling the +\fw{render\_} function on your child widgets. diff --git a/doc/ch3/widget_positioning.tex b/doc/ch3/widget_positioning.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/widget_positioning.tex @@ -0,0 +1,53 @@ +\section{Widget Positioning} +\label{sec:widget_positioning} + +Some widgets, such as the \fw{Edit} widget, need to position a cursor +in the terminal when they have the focus. To support this, each +widget stores its position after it is rendered. The positioning of +the widgets happens in a separate phase after rendering takes place +since the positions cannot be calculated until the sizes of all +widgets' \fw{Image}s are known. + +The top-level function to set a widget's position is called +\fw{setCurrentPosition} and is defined in the \fw{Core} module. It is +called initially by the \vtyui\ event loop with a position of \fw{(0, + 0)}. This function updates the \fw{currentPosition} field of the +widget's \fw{WidgetImpl} structure and then calls its +\fw{setCurrentPosition\_} function to take care of any widget-specific +duties. For most widgets, \fw{setCurrentPosition\_} need not be +overridden from its default no-op implementation. However, container +widgets \textit{must} override it to set the positions of their +children. + +Consider the \fw{Box} widget type. This type contains two child +widgets. The position of the \fw{Box} itself is the upper-left corner +of the space in which it is rendered, and that position is also the +position of its first child widget. The second child widget, however, +is offset (vertically or horizontally, depending on the box type) by +the size of the first child widget. This is an example of a case in +which implementing \fw{setCurrentPosition\_} is necessary. + +Here is an example implementation of \fw{setCurrentPosition\_} for the +\fw{Wrapper} widget that we examined in Section \ref{sec:deferring}: + +\begin{haskellcode} + setCurrentPosition_ = \this pos -> do + -- Since the position of the wrapper has already been + -- set by setCurrentPosition, we just need to set the + -- position of the child. + (Wrapper child) <- getState this + setCurrentPosition child pos +\end{haskellcode} + +The function calls the top-level \fw{setCurrentPosition} on the child +widget to ensure that its position is set and that its +\fw{setCurrentPosition\_} function is called. It uses the position of +the wrapper, \fw{pos}, as the position of the child because the +wrapper has not done anything to offset that position (e.g., by adding +an ASCII art border or padding). + +If you're implementing a container widget with more than one child, +you can use functions in the \fw{Util} module to manage the +\fw{DisplayRegion}s used to position your widgets. For more +information, see the \fw{withWidth}, \fw{withHeight}, \fw{plusWidth}, +and \fw{plusHeight} functions. diff --git a/doc/ch3/widgetimpl_api.tex b/doc/ch3/widgetimpl_api.tex new file mode 100644 --- /dev/null +++ b/doc/ch3/widgetimpl_api.tex @@ -0,0 +1,104 @@ +\section{The \fw{WidgetImpl} API} +\label{sec:widgetimpl_api} + +The \fw{WidgetImpl} type is the type of widget implementations. You +have already seen some of its fields in previous sections. + +\begin{haskellcode} + data WidgetImpl a = WidgetImpl { + state :: a + , render_ :: Widget a -> DisplayRegion -> RenderContext + -> IO Image + , growHorizontal_ :: a -> IO Bool + , growVertical_ :: a -> IO Bool + , setCurrentPosition_ :: Widget a -> DisplayRegion -> IO () + , getCursorPosition_ :: Widget a -> IO (Maybe DisplayRegion) + , focused :: Bool + , currentSize :: DisplayRegion + , currentPosition :: DisplayRegion + , normalAttribute :: Attr + , focusAttribute :: Attr + , keyEventHandler :: Widget a -> Key -> [Modifier] -> IO Bool + , gainFocusHandlers :: Handlers (Widget a) + , loseFocusHandlers :: Handlers (Widget a) + } +\end{haskellcode} + +The \fw{WidgetImpl} functions are similar to many top-level functions. +Whenever a \fw{Wid\-get\-Impl} function ends with an underscore, there +is a top-level function with the same name without the underscore that +you should use to invoke the respective functionality on any widget +reference you hold. We will see many examples of this convention in +this chapter. + +The following fields are managed automatically and should not be +overridden by widget implementors but are explained here for +completeness: + +\begin{itemize} +\item \fw{focused} -- \fw{True} if this widget is focused. As + explained in Section \ref{sec:focus}, although one widget has the + user's focus, internally many widgets may share it in a hierarchy. +\item \fw{currentSize} -- the ``current'' size of the widget, i.e., + the size of the \fw{Image} \textit{after} the last time the widget + was rendered. +\item \fw{currentPosition} -- the ``current'' position of the widget's + upper-left corner, i.e., the position of the widget's upper-left + corner \textit{after} the last time the widget was rendered. + Sometimes used when positioning child widgets and when positioning + the cursor, if any. +\item \fw{normalAttribute} -- the widget's normal attribute. Defaults + to Vty's \fw{def\_attr} value, which merges transparently with the + \fw{RenderContext}'s normal attribute. +\item \fw{focusAttribute} -- the widget's focus attribute. Defaults + to Vty's \fw{def\_attr} value, which merges transparently with the + \fw{RenderContext}'s focus attribute. +\item \fw{keyEventHandler} -- the action responsible for handling key + events for this widget. The default implementation merely starts + calling the sequence of user-registered key event handlers; it is + strongly recommended that you \textit{not} replace this, but use + \fw{onKeyPressed} to register key handlers instead. +\item \fw{gainFocusHandlers} -- the actions responsible for handling + the widget's focus gain event. You can add your own handlers with + \fw{onGainFocus} as described in Section \ref{sec:focus}. For more + information about event handling and the \fw{Handlers} type, see + Section \ref{sec:event_handlers}. +\item \fw{loseFocusHandlers} -- the actions responisible for handling + the widget's focus loss event. You can add your own handlers with + \fw{onLoseFocus} as described in Section \ref{sec:focus}. For more + information about event handling and the \fw{Handlers} type, see + Section \ref{sec:event_handlers}. +\end{itemize} + +The following fields are important to widget implementors and, +depending on widget requirements, need to be overridden: + +\begin{itemize} +\item \fw{state} -- the state of the widget as described in Section + \ref{sec:new_widget_type}. Use the \fw{getState} function to read + this state and use the \fw{updateWidgetState} function to modify it. +\item \fw{render\_} -- the rendering routine for the widget. If this + widget wraps child widgets, this function is responsible for + rendering them and composing the resulting \fw{Image}s into a final + \fw{Image}. +\item \fw{growHorizontal\_} -- the \textit{horizontal growth policy + function}. See Section \ref{sec:growth_policy_functions}. +\item \fw{growVertical\_} -- the \textit{vertical growth policy + function}. See Section \ref{sec:growth_policy_functions}. +\item \fw{setCurrentPosition\_} -- this function is used to set the + current position -- the position of the upper-left corner -- of the + widget. This is included in the \fw{WidgetImpl} API so that you can + override it if your widget wraps others or has special logic for + setting their positions. See Section \ref{sec:widget_positioning}. +\item \fw{getCursorPosition\_} -- this function may be used to + indicate that this widget should display a cursor when it has the + focus. The way that it does this is by returning a + \fw{DisplayRegion}. The default implementation returns + \fw{Nothing}, which indicates that the widget does not want to + position the cursor. For implementations which do show the cursor, + the returned position should be relative to the position returned by + \fw{getCurrentPosition}. See Section \ref{sec:cursor_positioning}. +\end{itemize} + +We've already introduced the \fw{state} and \fw{render\_} functions. +Now we'll go into detail on the use of the other functions. diff --git a/doc/ch4/Borders.tex b/doc/ch4/Borders.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Borders.tex @@ -0,0 +1,73 @@ +\section{Borders} +\label{sec:borders} + +The \fw{Borders} module provides a number border widgets which can be +created with the following functions: + +\begin{itemize} +\item \fw{vBorder} -- creates a vertical border of type \fw{Widget + VBorder} +\item \fw{hBorder} -- creates a horizontal border of type \fw{Widget + HBorder} +\item \fw{bordered} -- creates a bordered box of type \fw{Widget + (Bordered a)} around a widget of type \fw{Widget a} +\end{itemize} + +All border-drawing widgets use the \fw{RenderContext}'s \fw{Skin} as +described in Section \ref{sec:skinning}. By default, all borders will +use the \fw{RenderContext}'s normal attribute, but all border widget +types are instances of the \fw{HasBorderAttr} type class. This type +class makes it possible to specify the border attribute of these +widgets with the \fw{setBorderAttribute} function. + +The following example creates an interface using all three border +widget types. + +\begin{haskellcode} + b1 <- (plainText "foo") <--> hBorder <--> (plainText "bar") + b2 <- (return b1) <++> vBorder <++> (plainText "baz") + b3 <- bordered b2 +\end{haskellcode} + +Using the \fw{Box} combinators, we lay out text widgets separated by +different kinds of borders and wrap the entire interface in a +line-drawn box. + +When drawn with the \fw{asciiSkin}, this will result in the following +interface: + +\begin{verbatim} ++-------+ +|foo|baz| +|---| | +|bar| | ++-------+ +\end{verbatim} + +Horizontal and box borders support labels in their top borders. To +set the label on an \fw{HBorder}, use the \fw{setHBorderLabel} +function; for \fw{Bordered} widgets, use +\fw{set\-Bor\-dered\-La\-bel}. Using the example above, we can set +the label on \fw{b3} to \fw{"x"} to achieve the following result: + +\begin{haskellcode} + setBorderedLabel b3 "x" +\end{haskellcode} + +\begin{verbatim} ++-- x --+ +|foo|baz| +|---| | +|bar| | ++-------+ +\end{verbatim} + +If the \fw{Bordered} widget is not large enough to show the title, it +is hidden and a horizontal border is drawn instead. + +\subsubsection{Growth Policy} + +\fw{VBorder}s grow only vertically and are one column in width. +\fw{HBorder}s grow only horizontally and are one row in height. Box +borders created with \fw{bordered} inherit the growth policies of +their children. diff --git a/doc/ch4/Box.tex b/doc/ch4/Box.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Box.tex @@ -0,0 +1,84 @@ +\section{Boxes} + +The \fw{Box} module provides two box layout widgets which can be +created the following functions: + +\begin{itemize} +\item \fw{vBox} -- creates a box of type \fw{Widget (Box a b)} which + lays out two children of types \fw{Widget a} and \fw{Widget b} + vertically +\item \fw{hBox} -- creates a box of type \fw{Widget (Box a b)} which + lays out two children of types \fw{Widget a} and \fw{Widget b} + horizontally +\end{itemize} + +In addition, the box combinators \fw{<-->} and \fw{<++>} can be used +to create vertical and horizontal boxes, respectively, using widgets +in \fw{IO}. + +Box widgets have a \textit{child size policy} which determines how +space in the box is allocated to the child widgets. The size policy +type is \fw{ChildSizePolicy} and defaults to \fw{PerChild BoxAuto + BoxAuto} for new boxes. Each widget can have an individual policy +whose type is \fw{IndividualPolicy}; this policy can be set to +\fw{BoxAuto} or \fw{BoxFixed Int}. In the former case, space will be +allocated as needed; in the latter, the specified fixed number of rows +or columns (depending on the orientation of the \fw{Box}) will be +used. + +Use the \fw{setBoxChildSizePolicy} to change the box size policy to +one of the following kinds of values: + +\begin{itemize} +\item \fw{PerChild IndividualPolicy IndividualPolicy} -- set the + policies for each child widget. +\item \fw{Percentage Int} -- the total available space will be + allocated as a percentage. The number specified here is the + percentage $n$ ($0 \le n \le 100$) allocated to the first child; the + rest will be allocated to the second. The \fw{BoxError} exception + will be raised if an invalid percentage value is specified. +\end{itemize} + +Boxes may also be configured with a number of rows or columns of +spacing in between their child widgets; this is accomplished with the +\fw{setBoxSpacing} function. It takes a number of rows or columns, +depending on the orientation of the box. The function +\fw{withBoxSpacing} is provided as a convenience for setting the box +spacing in a monadic construction. + +The following example creates a box of each type to lay out some text +widgets: + +\begin{haskellcode} + b1 <- (plainText "foo") <++> (plainText "bar") >>= withBoxSpacing 1 + b2 <- (return b1) <--> (plainText "baz") >>= withBoxSpacing 1 +\end{haskellcode} + +The result is an inner horizontal box, \fw{b1}, containing two +\fw{FormattedText} widgets separated by one column, laid out on top of +another \fw{FormattedText} widget and separated by one row. + +\subsubsection{Growth Policy} + +\fw{Box}es grow in their respective dimensions if and only if: + +\begin{itemize} +\item One or more children can also grow in that dimension, and +\item The children which can grow are in box cells with the + \fw{Percentage} or \fw{BoxAuto} size policies set. +\end{itemize} + +\fw{Box}es grow in other dimensions merely if any children grow in +that dimension. + +Consider these examples: + +\begin{itemize} +\item A vertical \fw{Box} with a default size policy of \fw{BoxAuto} / + \fw{BoxAuto} will grow both vertically and horizontally if either + child grows respectively. +\item A vertical \fw{Box} with fixed-size cells will never grow + vertically, but will grow horizontally if either child does. +\item A horizontal \fw{Box} with one fixed-size cell will grow + horizontally if the child in the flexible cell grows horizontally. +\end{itemize} diff --git a/doc/ch4/Button.tex b/doc/ch4/Button.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Button.tex @@ -0,0 +1,35 @@ +\section{Buttons} + +The \fw{Button} module provides a button-like widget, \fw{Button}, +which can accept the focus and produce a ``pressed'' event when the +user presses \fw{Enter}. + +Buttons can be created with the \fw{newButton} function. The function +takes the text to be displayed on the button. + +\begin{haskellcode} + b <- newButton "OK" +\end{haskellcode} + +To handle ``button-press'' events, use the \fw{onButtonPressed} +function. Event handlers are passed a reference to the \fw{Button} +itself. + +\begin{haskellcode} + b `onButtonPressed` \this -> + ... +\end{haskellcode} + +To change the text of the button, use the \fw{setButtonText} function. +To ``press'' the button programmatically, call \fw{pressButton}. + +When you are ready to add the \fw{Button} to your interface, call its +\fw{buttonWidget} function: + +\begin{haskellcode} + box <- (plainText "Are you sure?") <--> (return (buttonWidget b)) +\end{haskellcode} + +\subsubsection{Growth Policy} + +\fw{Buttons} never grow in either dimension. diff --git a/doc/ch4/Centering.tex b/doc/ch4/Centering.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Centering.tex @@ -0,0 +1,29 @@ +\section{Centering} +\label{sec:centering} + +The \fw{Centering} module provides widgets for centering other widgets +horizontally and vertically: + +\begin{itemize} +\item \fw{hCentered} -- takes a \fw{Widget a} and centers it + horizontally. Returns a value of type \fw{Widget (HCentered a)}. +\item \fw{vCentered} -- takes a \fw{Widget a} and centers it + vertically. Returns a value of type \fw{Widget (VCentered a)}. +\item \fw{centered} -- takes a \fw{Widget a} and centers it both + horizontally and vertically using \fw{hCentered} and \fw{vCentered}. + Returns a value of type \fw{Widget (VCentered (HCentered a))}. +\end{itemize} + +Horizontal and vertical centering are only useful if the widget being +centered doesn't grow to fill the available space on its own, since it +would be as large as the available space and thus would be centered +implicitly. To constrain a growing widget to make it centerable, see +Sections \ref{sec:limits} and \ref{sec:fixed}. + +\subsubsection{Growth Policy} + +\fw{HCentered} widgets always grow horizontally and defer to their +children for vertical growth policy. Likewise, \fw{VCentered} widgets +always grow vertically and defer to their children for horizontal +growth policy. The \fw{centered} function returns a widget which +always grows in both directions. diff --git a/doc/ch4/CheckBox.tex b/doc/ch4/CheckBox.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/CheckBox.tex @@ -0,0 +1,167 @@ +\section{Checkboxes and Radio Buttons} + +The \fw{CheckBox} module provides a rich API for creating ``check +box'' and ``radio button'' widgets. Radio button widgets can be +grouped together into ``radio groups'' to determine their collective +exclusion behavior. + +The \fw{CheckBox} module provides generalized, ``multi-state'' +checkboxes which may be in one of an arbitrary number of states, each +having its own ``checked character'' visible in the checkbox. The +``binary'' checkbox provided by the module is of the traditional +two-state variety that we usually mean when we say ``check box.'' +Most of the \fw{CheckBox} module's functions are polymorphic on the +\fw{CheckBox}'s value type. + +Add a \fw{CheckBox} to your interface and insert it into a +\fw{FocusGroup} to use it. + +\subsection{Binary Checkboxes} + +Binary checkboxes can be created with the \fw{newCheckbox} function, +which returns a \fw{Wid\-get (Check\-Box Bool)}. Each checkbox has a +text label which is passed to the constructor: + +\begin{haskellcode} + cb <- newCheckbox "Fancy Graphics" +\end{haskellcode} + +Binary \fw{CheckBox}es look like this: + +\begin{verbatim} +[ ] Fancy Graphics +[x] Fancy Graphics +\end{verbatim} + +The user uses the \fw{Space} key to change the \fw{CheckBox} state. + +Event handlers for checkbox state changes can be registered with +\fw{onCheckboxChange} and take a single parameter, which is the value +of the checkbox after the state change occurs. In general, for a +checkbox of type \fw{Widget (CheckBox a)}, the parameter to the event +handler is of type \fw{a}. + +\begin{haskellcode} + cb `onCheckboxChange` \val -> + ... +\end{haskellcode} + +Binary \fw{CheckBox}es can be manipulated with the functions +\fw{set\-Checkbox\-Checked}, \fw{set\-Checkbox\-Unchecked}, and +\fw{toggle\-Checkbox}. + +\subsection{Radio Buttons} +\label{sec:radio_buttons} + +A radio button is essentially a checkbox, but with restrictions. We +use the \fw{CheckBox} implementation to create radio buttons and use a +``radio group'' type to enforce the mutual exclusion required to make +radio buttons work. As a result, only ``binary'' checkboxes (of type +\fw{Widget (CheckBox Bool)}) may be used as radio buttons. + +Radio buttons may be created by creating normal binary \fw{CheckBoxes} +and adding them to \fw{RadioGroup}s. A \fw{RadioGroup} can be created +with the \fw{newRadioGroup} function. + +\begin{haskellcode} + rg <- newRadioGroup + cb1 <- newCheckbox "Cake" + cb2 <- newCheckbox "Death" +\end{haskellcode} + +Once you have created the checkboxes and \fw{RadioGroup}, you can add +the checkboxes to the radio group with \fw{addToRadioGroup}: + +\begin{haskellcode} + addToRadioGroup rg cb1 + addToRadioGroup rg cb2 +\end{haskellcode} + +Once a \fw{CheckBox} has been added to a \fw{RadioGroup}, its +appearance will be changed to indicate that it has a different +behavior. \fw{CheckBox}es in \fw{RadioGroup}s look like this: + +\begin{verbatim} +( ) Cake +(*) Death +\end{verbatim} + +If you'd like to know when a \fw{RadioGroup}'s currently-selected +\fw{CheckBox} changes, you can register an event handler for this +event with \fw{onRadioChange}. Its parameter will be a reference to +the \fw{CheckBox} that became selected: + +\begin{haskellcode} + rg `onRadioChange` \theCb -> + ... +\end{haskellcode} + +Once you have a reference to a \fw{CheckBox}, you can get its state +with \fw{getCheckboxState}. For example, for binary checkboxes this +value will be a \fw{Bool}. + +\begin{haskellcode} + rg `onRadioChange` \theCb -> do + st <- getCheckboxState theCb + ... +\end{haskellcode} + +A \fw{CheckBox}'s state can be changed with the \fw{setCheckboxState} +function. If you attempt to set the state to an invalid value, a +\fw{CheckBoxError} exception (\fw{Bad\-Checkbox\-State}) will be +thrown. + +In addition to using an event handler to be notified when a +\fw{RadioGroup} changes state, you can also use the +\fw{getCurrentRadio} function to get a \fw{Radio\-Group}'s current +\fw{Check\-Box} at any time. + +\subsection{Generalized, Multi-State Checkboxes} + +Although binary checkboxes may serve most purposes, they are a +specific case of generalized checkboxes which associated characters +(like \fw{'x'} and \fw{'*'} above) with values of any type. A +multi-state checkbox can have any number of these states, and the user +can toggle between them in order. + +To create a new multi-state checkbox, you must specify value-character +mappings in addition to a text label. The checkbox's initial state is +the first one in the list passed to the constructor. + +\begin{haskellcode} + -- cb :: Widget (CheckBox Int) + cb <- newMultiStateCheckbox "Number of Cakes" [ (1, '1') + , (2, '2') + , (3, '3') + ] +\end{haskellcode} + +When the user interacts with a multi-state \fw{CheckBox}, repeated +state changes will cycle through the list of values specified in the +constructor. In all other respects, multi-state checkboxes are the +same as binary checkboxes, and all polymorphic API functions can be +used on them. + +\subsection{Customizing a \fw{CheckBox}'s Appearance} + +We saw in Section \ref{sec:radio_buttons} that the appearance of a +\fw{CheckBox} can be changed. This is accomplished with the following +functions: + +\begin{itemize} +\item \fw{setStateChar} -- given a \fw{CheckBox} and a state value, + the character representation of that state will be set. If the + state value is invalid, \fw{CheckBoxError} + (\fw{Bad\-State\-Argument}) will be thrown. As an example, the + default state characters for binary checkboxes for \fw{True} and + \fw{False}, respectively, are \fw{'x'} and \fw{' '}. +\item \fw{setBracketChars} -- given a \fw{CheckBox} and two + \fw{Char}s, this sets the left and right characters, respectively, + which surround the state character. The defaults are \fw{'['} and + \fw{']'}. +\end{itemize} + +\subsubsection{Growth Policy} + +All \fw{CheckBox}es are fixed-size and do not grow in either +dimension. diff --git a/doc/ch4/Collection.tex b/doc/ch4/Collection.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Collection.tex @@ -0,0 +1,40 @@ +\section{Collections} + +The \fw{EventLoop} module provides the \fw{Collection} type, which is +a container for multiple widgets and their \fw{FocusGroup}s with a +pointer to a ``currently-selected'' widget and \fw{FocusGroup}. +\fw{Collection}s are used to construct interfaces as described in +Section \ref{sec:collections}. + +To create a new collection: + +\begin{haskellcode} + c <- newCollection +\end{haskellcode} + +A \fw{Collection} is not a widget so it cannot be treated like one. +However, the primary operation of interest is the \fw{addToCollection} +function, which adds an arbitrary \fw{Widget a} and \fw{FocusGroup} to +the \fw{Collection} and returns an \fw{IO} action which, when run, +will switch to that interface and focus group. + +\begin{haskellcode} + switchToFoo <- addToCollection c fooUi fooFocusGroup + someWidget `onEvent` (const switchToFoo) +\end{haskellcode} + +If you choose not to use the \fw{IO} action returned by +\fw{addToCollection}, you may instead call \fw{setCurrentEntry}. This +function takes a \fw{Collection} and a position and sets the +\fw{Collection}'s current entry to the one at the specified position. +The position is an index into the \fw{Collection}'s internal list of +interfaces. If the position is invalid, a \fw{CollectionError} is +thrown. + +\begin{haskellcode} + _ <- addToCollection c fooUi fooFocusGroup + someWidget `onEvent` (const $ setCurrentEntry c 0) +\end{haskellcode} + +If an empty \fw{Collection} is used in any way, a \fw{CollectionError} +will be thrown. diff --git a/doc/ch4/Dialog.tex b/doc/ch4/Dialog.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Dialog.tex @@ -0,0 +1,57 @@ +\section{Dialogs} +\label{sec:dialogs} + +The \fw{Dialog} module provides a basic accept/cancel dialog widget +interface and is capable of embedding arbitrary widgets. + +Dialog creation is straightforward. The following example will create +a new dialog with an embedded \fw{Edit} widget and will set the +\fw{Dialog}'s title: + +\begin{haskellcode} + fg1 <- newFocusGroup + e <- editWidget + addToFocusGroup fg e + + (dlg, fg2) <- newDialog e "The Title" + fg <- mergeFocusGroups fg1 fg2 +\end{haskellcode} + +The \fw{newDialog} function returns a \fw{Dialog} and a +\fw{FocusGroup}. The \fw{Dialog} includes two \fw{Button}s -- an +``OK'' button and a ``Cancel'' button -- and the returned +\fw{Focus\-Group} contains those buttons in that order. You can merge +the \fw{FocusGroup} with your own or use it directly as described in +Section \ref{sec:focus}. + +The \fw{Dialog} itself is a composite type; the way to lay out a +\fw{Dialog} in your interface is by laying out the \fw{Dialog}'s +widget: + +\begin{haskellcode} + let ui = dialogWidget dlg +\end{haskellcode} + +The \fw{Dialog} type provides two events: acceptance and cancellation. +The following example registers handlers for both of these events. +These events are triggered when the user ``presses'' the buttons in +the \fw{Dialog}. + +\begin{haskellcode} + dlg `onDialogAccept` \this -> + ... + dlg `onDialogCancel` \this -> + ... +\end{haskellcode} + +To programmatically trigger the acceptance or cancellation of a +\fw{Dialog}, use the \fw{accept\-Dialog} and \fw{cancel\-Dialog} +functions. + +\subsubsection{Growth Policy} + +A \fw{Dialog}'s growth policy depends on the growth policy of the +widget embedded in it. The \fw{Dialog}'s interface uses fixed-size +widgets, so it will not grow in either dimension unless you embed a +widget which grows. In the example above, the \fw{Dialog} will grow +horizontally due to the \fw{Edit} widget but will not grow vertically. diff --git a/doc/ch4/DirBrowser.tex b/doc/ch4/DirBrowser.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/DirBrowser.tex @@ -0,0 +1,154 @@ +\section{The Directory Browser} +\label{sec:dirbrowser} + +The \fw{DirBrowser} module provides a rich interface for browsing the +filesystem to select files. The user is presented with an interface +in which different file types are given different colors, and a status +bar shows some information about the currently-selected file or +directory. If the user attempts to browse an unreadable directory or +get information about an unreadable file, an error is displayed in the +browser interface. + +The \fw{DirBrowser} uses a \fw{List} widget for selecting files and +directories, so the \fw{List} keybindings apply here. In total, the +directory browser supports the following key bindings: + +\begin{itemize} +\item \fw{Enter} -- descends into a directory or selects a file. +\item \fw{Left} -- ascends to the parent directory. +\item \fw{Right} -- descends into a selected directory. +\item \fw{Up}, \fw{Down} -- changes the currently-selected entry. +\item \fw{'q'}, \fw{Esc} -- cancels browsing. +\item \fw{'r'} -- refreshes the browser's state of the current + directory. +\end{itemize} + +\fw{DirBrowser}s are created as follows: + +\begin{haskellcode} + browser <- newDirBrowser defaultBrowserSkin +\end{haskellcode} + +The browser's initial filesystem path will be the application's +current directory. You can change it with the \fw{setDirBrowserPath} +function: + +\begin{haskellcode} + setDirBrowserPath browser "/" +\end{haskellcode} + +To be notified when the user has selected a file, register an event +handler with \fw{on\-Browse\-Accept}. The handler will be passed the +\fw{FilePath} to the file which was selected. + +\begin{haskellcode} + browser `onBrowseAccept` \path -> ... +\end{haskellcode} + +Similarly, to be notified when the user has cancelled browsing, +register an event handler with \fw{onBrowseCancel}. The handler will +be passed the browser's path at the time of cancellation. + +\begin{haskellcode} + browser `onBrowseCancel` \path -> ... +\end{haskellcode} + +To be notified when the user changes the browser's current path, use +\fw{on\-Browser\-Path\-Change}. The event handler will be passed the +new browser path. + +\begin{haskellcode} + browser `onBrowserPathChange` \path -> ... +\end{haskellcode} + +\subsection{Skinning} + +When creating a \fw{DirBrowser}, we pass it a \fw{BrowserSkin}. This +value affects how the browser colors the different types of filesystem +entries it displays in addition to how it colors the rest of its +interface. You can customize the browser skin by updating any of its +fields with Vty attributes of your choosing. + +\begin{haskellcode} + browser <- newDirBrowser $ defaultBrowserSkin { ... } +\end{haskellcode} + +The attribute fields of the \fw{BrowserSkin} type are as follows: + +\begin{itemize} +\item \fw{browserHeaderAttr} -- used for the header and footer of the + browser interface. +\item \fw{browserUnfocusedSelAttr} -- used for the selected entry when + the browser is not focused. +\item \fw{browserErrorAttr} -- used for the text widget which displays + errors encountered while browsing. +\item \fw{browserDirAttr} -- used for directories. +\item \fw{browserLinkAttr} -- used for symbolic links. +\item \fw{browserBlockDevAttr} -- used for block device files. +\item \fw{browserNamedPipeAttr} -- used for named pipes. +\item \fw{browserCharDevAttr} -- used for character device files. +\item \fw{browserSockAttr} -- used for sockets. +\end{itemize} + +When the browser is focused, it uses the \fw{RenderContext}'s +\fw{focusAttr} for the currently-selected entry in the \fw{List}. + +\subsection{Annotations} + +For each type of file on the filesystem, the browser displays the kind +of file in addition to some information about it. For example, for +regular files, the size is displayed. For symbolic links, the link +target is displayed. + +It may be important to add your own such enhancements to the browser. +For example, you may want to apply an attribute to files with a +specific extension to make them easy to see in the browser. In +addition you may wish to generate a description about the file in the +status bar. To accomplish this, the \fw{DirBrowser} provides +\textit{annotations}. + +An annotation is made up of three components: + +\begin{itemize} +\item A predicate to determine whether the annotation should apply to + a given file, +\item A function to generate a description of the file such as its + size or application-specific metadata, and +\item An attribute to apply to files of this type in the browser + listing. +\end{itemize} + +Annotations are stored in the \fw{BrowserSkin} itself since they are +used to influence the browser's appearance. To add annotations to a +skin, use \fw{withAnnotations}. The following example adds an +annotation for ``emacs backup files,'' which end in \fw{'\string~'}: + +\begin{haskellcode} + let mySkin = defaultBrowserSkin `withAnnotations` myAnnotations + myAnnotations = [ ( \path _ -> "~" `isSuffixOf` path + , \_ _ -> return "emacs backup file" + , green `on` blue + ) + ] +\end{haskellcode} + +For the full specification of the annotation's type, please see the +API documentation. + +\subsection{Error Reporting} + +When a user selects a file in the browser, your application may +determine that the file does not meet certain requirements. At this +point it may be useful to report an error to the user without leaving +the browser interface. The \fw{DirBrowser} provides a function to do +just this called \fw{reportBrowserError}. The function displays an +error message in the browser's error message area. + +\begin{haskellcode} + browser `onBrowseAccept` \path -> + reportBrowserError browser $ "not a valid document: " ++ path +\end{haskellcode} + +\subsubsection{Growth Policy} + +A \fw{DirBrowser} expands both vertically and horizontally. diff --git a/doc/ch4/Edit.tex b/doc/ch4/Edit.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Edit.tex @@ -0,0 +1,75 @@ +\section{Edit Widgets} +\label{sec:edit} + +The \fw{Edit} module provides a line-editing widget, \fw{Widget Edit}. +This widget makes it possible to edit a single line of text with some +Emacs-style key bindings. + +An \fw{Edit} widget is simple to create: + +\begin{haskellcode} + e <- editWidget +\end{haskellcode} + +\fw{Edit} widgets can be laid out in the usual way: + +\begin{haskellcode} + e <- editWidget + b <- (plainText "Enter a string: ") <++> (return e) +\end{haskellcode} + +To use an \fw{Edit} widget, add it to your interface and +\fw{FocusGroup}. + +\fw{Edit} widgets support the following editing key bindings: + +\begin{itemize} +\item \fw{Ctrl-a}, \fw{Home} -- go to the beginning of the line. +\item \fw{Ctrl-e}, \fw{End} -- go to the end of the line. +\item \fw{Ctrl-k} -- remove the text from the cursor position to the + end of the line. +\item \fw{Ctrl-d}, \fw{Del} -- delete the character at the cursor + position. +\item \fw{Left}, \fw{Right}, \fw{Up}, \fw{Down} -- change the cursor + position. +\item \fw{Backspace} -- delete the character just before the cursor + position and move the cursor position back by one character. +\item \fw{Enter} -- ``activate'' the \fw{Edit} widget. +\end{itemize} + +An \fw{Edit} widget can be monitored for three events: + +\begin{itemize} +\item ``Activation'' events -- triggered when the user presses + \fw{Enter} in the \fw{Edit} widget. Handlers are registered with + the \fw{onActivate} function. Event handlers receive the \fw{Edit} + widget as a parameter. +\item Text change -- when the contents of the \fw{Edit} widget change. + Handlers are registered with the \fw{onChange} function. Event + handlers receive the new \fw{String} value in the \fw{Edit} widget. +\item Cursor movement -- when the cursor position within the \fw{Edit} + widget changes. Handlers are registered with the \fw{onCursorMove} + function. Event handlers receive the new cursor position as a + parameter. +\end{itemize} + +In addition to event handling, the \fw{Edit} widget API also provides +other functions. These functions trigger the respective events +automatically. + +\begin{itemize} +\item \fw{setEditText}, \fw{getEditText} -- change the current text + content of the \fw{Edit} widget. +\item \fw{getEditCursorPosition}, \fw{setEditCursorPosition} -- + manipulate the cursor position within the \fw{Edit} widget. +\item \fw{setEditMaxLength} -- set the maximum number of characters in + the \fw{Edit} widget. Once set, the limit cannot be removed but it + can be changed to a different value. If \fw{setEditMaxLength} is + called with a limit which is less than the limit already set, the + content of the \fw{Edit} widget will be truncated and any change + event handlers will be notified. +\end{itemize} + +\subsubsection{Growth Policy} + +\fw{Edit} widgets grow only horizontally and are always one row high. diff --git a/doc/ch4/Fills.tex b/doc/ch4/Fills.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Fills.tex @@ -0,0 +1,22 @@ +\section{Fills} + +The \fw{Fills} module provides space-filling widgets which can be used +to add ``flexible'' space to control layout. Fixed-size widgets often +need flexible space to fill the terminal, so we use ``fill'' widgets +to do this. + +There are two types of fills: + +\begin{itemize} +\item Horizontal, created by the \fw{hFill} function. \fw{hFill} + takes a fill character and a height and fills available space with + that character using the current attribute settings. +\item Vertical, created by the \fw{vFill} function. \fw{vFill} takes + a fill character and fills available space with that character using + the current attribute settings. +\end{itemize} + +\subsubsection{Growth Policy} + +\fw{HFill}s always grow horizontally but not vertically. \fw{VFill}s +always grow vertically but not horizontally. diff --git a/doc/ch4/Fixed.tex b/doc/ch4/Fixed.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Fixed.tex @@ -0,0 +1,63 @@ +\section{Fixed-Size Widgets} +\label{sec:fixed} + +The \fw{Fixed} module provides widget containers which fix the amount +of spaced used to render the child. This can be useful when you know +that an element of your interface has the potential to fill available +space but must be fixed to a specific size for some reason. + +The module provides widget types for constraining the horizontal or +vertical size of a widget. The fixed-size widget containers are +created with the following functions: + +\begin{itemize} +\item \fw{hFixed} -- takes a widget \fw{Widget a} and a width in + columns and constrains the widget to the specified width. Returns a + widget of type \fw{Widget (HFixed a)}. If the \fw{HFixed} widget + does not have enough space to enforce the specified width, the + available space is used instead. +\item \fw{vFixed} -- takes a widget \fw{Widget a} and a height in rows + and constrains the widget to the specified height. Returns a widget + of type \fw{Widget (VFixed a)}. If the \fw{VFixed} widget does not + have enough space to enforce the specified height, the available + space is used instead. +\item \fw{boxFixed} -- takes a widget \fw{Widget a}, a width in + columns, and a height in rows and constrains the widget in both + dimensions. Returns a widget of type \fw{Widget (VFixed (HFixed + a))}. +\end{itemize} + +In addition to widget creation, some manipulation functions are +provided so that the fixed-size container settings can be manipulated +as desired: + +\begin{itemize} +\item \fw{setVFixed}, \fw{setHFixed} -- sets the constraint value for + a fixed-size widget. +\item \fw{addToVFixed}, \fw{addToHFixed} -- adds a value to the + constraint value of a fixed-size widget. +\item \fw{getVFixedSize}, \fw{getHFixedSize} -- returns the constraint + value of a fixed-size widget. +\end{itemize} + +For example, the \fw{List} widget type (Section \ref{sec:lists}) grows +vertically but we may wish to dedicate most of the terminal to the +rest of the interface. We can use \fw{vFixed} to constrain the +\fw{List} in this way. Below, we constrain the \fw{List} to five rows +of height. Assuming the \fw{List} elements are each one row high, if +the \fw{List} has fewer than five elements to display then the +\fw{VFixed} widget will automatically pad the \fw{List} to ensure that +it takes up the specified number of rows. Fixed-size widgets thus +guarantee that the specified space is consumed. + +\begin{haskellcode} + lst <- newList (green `on` black) plainText + ui <- vFixed 5 lst +\end{haskellcode} + +\subsubsection{Growth Policy} + +Since \fw{VFixed} and \fw{HFixed} widgets are designed to constrain +their children in a specific dimension, they never grow in the +constrained dimension. For the other dimension, fixed-size widgets +always defer to their children for the growth policy. diff --git a/doc/ch4/FormattedText.tex b/doc/ch4/FormattedText.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/FormattedText.tex @@ -0,0 +1,67 @@ +\section{Text} +\label{sec:text} + +The \fw{Text} module provides a widget for rendering text strings in +user interfaces. The text widget type, \fw{Widget FormattedText}, can +be used to render simple strings or more complex text arrangements. + +A \fw{FormattedText} widget can be created from a \fw{String} with the +\fw{plainText} function and can be laid out in the usual way: + +\begin{haskellcode} + t1 <- plainText "blue" >>= withNormalAttribute (fgColor blue) + t2 <- plainText "green" >>= withNormalAttribute (fgColor green) + ui <- (return t1) <++> (return t2) +\end{haskellcode} + +\subsection{Formatters} + +In addition to rendering plain text strings, we can use ``formatters'' +to change the arrangement and attributes of text. Formatters can +manipulate structure and attributes to change the text layout and +appearance. + +To use a formatter with a text widget, we must use a different +constructor function, \fw{text\-Widget}: + +\begin{haskellcode} + t <- textWidget "foobar" wrap +\end{haskellcode} + +When formatters are applied, the text is automatically broken up into +``tokens,'' each of which indicates sequences of whitespace or +non-whitespace characters. Each token stores its own attribute and it +is these tokens on which formatters operate. + +The \fw{Text} module provides two formatters: \fw{wrap} and +\fw{highlight}. \fw{wrap} wraps the text to fit into the +\fw{DisplayRegion} available at rendering time. \fw{highlight} uses +the \fw{pcre-light}\footnote{\fw{pcre-light} on Hackage: + \href{http://hackage.haskell.org/package/pcre-light-0.3.1.1}{http://hackage.haskell.org/package/pcre-light-0.3.1.1}} +library to highlight text using ``Perl-compatible'' regular +expressions. To construct a highlighting formatter, we must provide +the regular expression used to match strings as well as the attribute +that should be applied to the matches:\footnote{Since + formatters operate on individual tokens, the \fw{highlight} + formatter applies its regular expression to each token individually, + so it will only ever match sequences of characters in each token + rather than matching more than one token.} + +\begin{haskellcode} + let doHighlight = highlight (compile (pack "bar") []) + (fgColor bright_green) + t <- textWidget "Foo bar baz" doHighlight +\end{haskellcode} + +Formatters can be composed with the \fw{\&.\&} operator. This +operator constructs a new formatter which will apply the operand +formatters in the specified order. We can use this operator to +compose the built-in formatters on a single \fw{FormattedText} widget: + +\begin{haskellcode} + t <- textWidget "Foo bar baz" (doHighlight &.& wrap) +\end{haskellcode} + +\subsubsection{Growth Policy} + +\fw{FormattedText} widgets do not grow horizontally or vertically. diff --git a/doc/ch4/Limits.tex b/doc/ch4/Limits.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Limits.tex @@ -0,0 +1,46 @@ +\section{Limits} +\label{sec:limits} + +The \fw{Limits} module provides widgets for setting upper bounds on +the sizes of other widgets. These widgets differ from the \fw{Fixed} +module we saw in Section \ref{sec:fixed}; ``limit'' widgets do not pad +their children if the children render to \fw{Image}s smaller than the +specified space, whereas fixed-size widgets pad their children, thus +guaranteeing that the specified space will be consumed. + +The limiting widget API is similar to that of the \fw{Fixed} module. +Limiting widgets are created as follows: + +\begin{itemize} +\item \fw{hLimit} -- takes a widget \fw{Widget a} and a width in + columns and constrains the widget to the specified width. Returns a + widget of type \fw{Widget (HLimit a)}. If the \fw{HLimit} widget + does not have enough space to enforce the specified width, the child + widget is not padded. +\item \fw{vLimit} -- takes a widget \fw{Widget a} and a height in rows + and constrains the widget to the specified height. Returns a widget + of type \fw{Widget (VLimit a)}. If the \fw{VLimit} widget does not + have enough space to enforce the specified height, the child widget + is not padded. +\item \fw{boxLimit} -- takes a widget \fw{Widget a}, a width in + columns, and a height in rows and constrains the widget in both + dimensions. Returns a widget of type \fw{Widget (VLimit (HLimit + a))}. If the child widget is smaller, it is not padded. +\end{itemize} + +In addition to widget creation, some manipulation functions are +provided so that the limit settings can be manipulated as desired: + +\begin{itemize} +\item \fw{setVLimit}, \fw{setHLimit} -- sets the constraint value for + a limiting widget. +\item \fw{addToVLimit}, \fw{addToHLimit} -- adds a value to the + constraint value of a limiting widget. +\item \fw{getVLimitSize}, \fw{getHLimitSize} -- returns the constraint + value of a limiting widget. +\end{itemize} + +\subsubsection{Growth Policy} + +Limiting widgets never grow in the constrained dimension and defer to +their children for growth policy otherwise. diff --git a/doc/ch4/List.tex b/doc/ch4/List.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/List.tex @@ -0,0 +1,168 @@ +\section{Lists} +\label{sec:lists} + +The \fw{List} module provides a rich interface for displaying, +navigating, and selecting from a list of elements. + +\fw{List}s support the following key bindings: + +\begin{itemize} +\item \fw{Up}, \fw{Down} -- changes the currently-selected element by + one element in the respective direction. +\item \fw{PageUp}, \fw{PageDown} -- changes the currently-selected + element by a page of elements, which depends on the number of + elements currently shown in the list. +\item \fw{Enter} -- notifies event handlers that the + currently-selected item has been ``activated.'' +\end{itemize} + +Lists are implemented with the type \fw{List a b}. Its two type +parameters are as follows: + +\begin{itemize} +\item \textit{internal item type}, \fw{a} -- This is the type of the + application-specific value stored in each list item. This is the + data that is represented by the visual aspect of the list element + and it will not necessarily have anything to do with the visual + representation. +\item \textit{item widget type}, \fw{b} -- This is the type of the + widget state of each element as it is represented in the interface. + For example, a simple list of strings might use \fw{String} as its + internal value type and \fw{Widget FormattedText} (Section + \ref{sec:text}) as its widget type, resulting in a list of type + \fw{List String FormattedText}. +\end{itemize} + +Lists are created with the \fw{newList} function: + +\begin{haskellcode} + lst <- newList attr plainText +\end{haskellcode} + +\fw{newList} takes two parameters: the attribute of the +currently-selected item to be used when the list is \textit{not} +focused, and the \textit{constructor function} to be used to create +widgets when new items are added to the list. The \fw{List} uses its +own focus attribute (Section \ref{sec:attributes}) as the attribute of +the currently-selected item when it has the focus. + +Items may be added to a \fw{List} with the \fw{addToList} function, +which takes an internal value (e.g., \fw{String}) and uses it to +construct a widget with the appropriate type (e.g., \fw{Widget + FormattedText}): + +\begin{haskellcode} + addToList lst "foobar" +\end{haskellcode} + +The constructor function passed to \fw{newList} is essentially a +specification of how list items should be represented. For a \fw{List + a b}, it must take a value of type \fw{a} and return a \fw{Widget + b}. There are two restrictions on the constructor's return value: + +\begin{itemize} +\item The \fw{Widget b} type \textit{must not grow vertically}. This + is because all \fw{List} item widgets must take up a fixed amount of + vertical space so the \fw{List} can manage scrolling. If the widget + grows vertically, \fw{addToList} will throw a \fw{ListError} + exception. +\item All widgets returned \textit{must have the same height}. This + is because the list uses the item height to calculate how many items + can be displayed, given the space available to the rendered + \fw{List}. If the constructor creates a widget whose rendered size + doesn't match that of the rest of the wigets of the list, layout + problems are likely to ensue. +\end{itemize} + +Items may be removed from \fw{List}s with the \fw{removeFromList} +function, which takes a \fw{Widget (List a b)} and an item position, +removes the item at the specified position, and returns the removed +item: + +\begin{haskellcode} + (val, w) <- removeFromList lst 0 +\end{haskellcode} + +If the position is invalid, a \fw{ListError} is thrown. +\fw{removeFromList} returns the internal value (\fw{val}) and the +corresponding widget (\fw{w}) of the removed list entry. + +All of the items can be removed from a \fw{List} with the +\fw{clearList} function. \fw{clearList} does \textit{not} invoke any +event handlers for the removed items. + +\subsection{\fw{List} Inspection} + +The \fw{List} module provides some functions to get information about +the state of a \fw{List}: + +\begin{itemize} +\item \fw{getListSize} -- returns the number of elements in a + \fw{List}. +\item \fw{getSelected} -- takes a \fw{Widget (List a b)} and returns + \fw{Nothing} if the \fw{List} is empty or returns \fw{Just (pos, + (val, widget))} corresponding to the list index, internal item + value, and widget of the currently-selected list item. +\end{itemize} + +\subsection{Scrolling a \fw{List}} +\label{sec:list_scrolling} + +Although the list key bindings are bound to the \fw{List}'s scrolling +behavior, the \fw{List} module exports the scrolling functions for +programmatic manipulation of \fw{List}s. Note that in all cases, the +scrolling functions change the position of the currently-selected item +and, if necessary, scroll the list in the terminal to reveal the +newly-selected item. + +\begin{itemize} +\item \fw{scrollUp} -- moves the selected item position toward the + beginning of the \fw{List} by one position. +\item \fw{scrollDown} -- moves the selected item position toward the + end of the \fw{List} by one position. +\item \fw{pageUp} -- moves the selected item position toward the + beginning of the \fw{List} by one page; the size of a page depends + on the height of the \fw{List}'s widgets and the amount of space + available to the rendered \fw{List}. +\item \fw{pageDown} -- moves the selected item position toward the end + of the \fw{List} by one page; the size of a page depends on the + height of the \fw{List}'s widgets and the amount of space available + to the rendered \fw{List}. +\item \fw{scrollBy} -- takes a number of positions and moves the + selected item position in the specified direction. If the number is + negative, this scrolls toward the beginning of the \fw{List}, + otherwise, it scrolls toward the end. +\end{itemize} + +\subsection{Handling Events} + +The \fw{List} type produces a variety of events: + +\begin{itemize} +\item \textit{scrolling events} -- events indicating that the position + of the currently-selected item has changed. Handlers are registered + with \fw{onSelectionChange} and receive an event value of type + \fw{SelectionEvent}. A \fw{SelectionEvent} describes whether the + selection has been turned ``off'', which happens when the last + element in the \fw{List} is removed, or whether it is on and + corresponds to an item. +\item \textit{item events} -- events indicating that an item has been + added to or removed from the \fw{List}. Handlers for added items + are registered with \fw{onitemAdded} receive event values of type + \fw{NewItemEvent}. Handlers for removed items are registered with + \fw{onItemRemoved} and receive event values of type + \fw{RemoveItemEvent}. +\item \textit{item activation} -- events indicating that the + currently-selected item was \textit{activated}, which occurs when + the user presses \fw{Enter} on a focused \fw{List}. Handlers for + activation events are registered with \fw{onItemActivated} and + receive event values of type \fw{ActivateItemEvent}. +\end{itemize} + +Scrolling events are generated by the functions described in Section +\ref{sec:list_scrolling}. Item activation may be triggered +programmatically with the \fw{activateCurrentItem} function. + +\subsubsection{Growth Policy} + +\fw{List}s always grow both horizontally and vertically. diff --git a/doc/ch4/Padded.tex b/doc/ch4/Padded.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Padded.tex @@ -0,0 +1,59 @@ +\section{Padding} +\label{sec:padding} + +The \fw{Padding} module provides a wrapper widget type, \fw{Padded}, +which wraps another widget with a specified amount of padding on any +or all four of its sides. + +We create padded widgets with the \fw{padded} function, which takes a +child of type \fw{Widget a} and a padding value. In the following +example we create a \fw{FormattedText} widget and pad it on all sides +by two rows (or columns, where appropriate): + +\begin{haskellcode} + w <- plainText "foobar" + w2 <- padded w (padAll 2) +\end{haskellcode} + +The padding itself is expressed with the \fw{Padding} type, whose +values store padding settings for the top, bottom, left, and right +sides of an object in question. \fw{Padding} values are created with +one of the following functions: + +\begin{itemize} +\item \fw{padNone} -- creates a \fw{Padding} value with no padding. +\item \fw{padAll} -- takes a single parameter, \fw{p}, and creates a + \fw{Padding} value with \fw{p} rows or columns of padding on all + four sides. +\item \fw{padLeft}, \fw{padRight}, \fw{padTop}, \fw{padBottom} -- each + takes a single parameter and creates a \fw{Padding} value with the + specified amount of padding on the specified side indicated by the + function name. +\item \fw{padLeftRight}, \fw{padTopBottom} -- each takes a single + parameter and creates a \fw{Pad\-ding} value with the specified + amount of padding on both sides indicated by the function name. +\end{itemize} + +With these basic \fw{Padding} constructors we can construct more +interesting \fw{Padding} values with the \fw{pad} function: + +\begin{haskellcode} + let p = padNone `pad` (padAll 5) `pad` (padLeft 2) +\end{haskellcode} + +The \fw{Padding} type is an instance of the \fw{Paddable} type class, +of which \fw{pad} is the only method. The \fw{Padding} instance of +\fw{Paddable} just adds the padding values together. + +In addition to the \fw{padded} function, the \fw{Padding} module +provides the \fw{withPadding} combinator to created a \fw{Padded} +widget in the following way: + +\begin{haskellcode} + w <- plainText "foobar" >>= withPadding (padAll 2) +\end{haskellcode} + +\subsubsection{Growth Policy} + +\fw{Padded} widgets always defer to their children for both horizontal +and vertical growth policy. diff --git a/doc/ch4/ProgressBar.tex b/doc/ch4/ProgressBar.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/ProgressBar.tex @@ -0,0 +1,48 @@ +\section{Progress Bars} +\label{sec:progress_bars} + +The \fw{ProgressBar} module provides the \fw{ProgressBar} type which +you can use to indicate task progression in your applications. + +\fw{ProgressBar}s can be created with the \fw{newProgressBar} +function. The function takes two \fw{Color} arguments indicating the +colors to be used for the complete and incomplete portions of the +progress bar, respectively: + +\begin{haskellcode} + bar <- newProgressBar blue white +\end{haskellcode} + +\fw{ProgressBar}s are composite widgets; to lay them out in your +applications, use the \fw{progressBarWidget} function: + +\begin{haskellcode} + ui <- (plainText "Progress: ") <--> (return $ progressBarWidget bar) +\end{haskellcode} + +A \fw{ProgressBar} tracks progress as an \fw{Int} n ($0 \le n \le +100$). To set a \fw{ProgressBar}'s progress value, use +\fw{setProgress} or \fw{addProgress}: + +\begin{haskellcode} + setProgress bar 35 + addProgress bar 1 +\end{haskellcode} + +Calls to \fw{setProgress} and \fw{addProgress} resulting in a progress +value outside the allowable range will have no effect. + +To be notified when a \fw{ProgressBar}'s value changes, use the +\fw{onProgressChange} function. Handlers for this event will receive +the new progress value: + +\begin{haskellcode} + bar `onProgressChange` \newVal -> ... +\end{haskellcode} + +\fw{ProgressBar}s are best used with the \fw{schedule} function +described in Section \ref{sec:concurrency}. + +\subsubsection{Growth Policy} + +\fw{ProgressBar}s grow horizontally but do not grow vertically. diff --git a/doc/ch4/Table.tex b/doc/ch4/Table.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Table.tex @@ -0,0 +1,225 @@ +\section{Tables} +\label{sec:tables} + +The \fw{Table} module provides a table layout widget which embeds +other widgets and provides full control over column and cell padding, +alignment, and cell borders. + +The \fw{Table} creation function \fw{newTable} requires two parameters +which govern the overall table behavior: + +\begin{itemize} +\item \textit{column specifications} -- a list of values specifying + how each column in the table is to behave, including its width + policy, alignment, and padding settings +\item \textit{border configuration} -- a value specifying how the + table's borders are to be drawn (if any) +\end{itemize} + +Here is an example of a table with two columns and full borders: + +\begin{haskellcode} + tbl <- newTable [column (ColFixed 10), column ColAuto] BorderFull +\end{haskellcode} + +To add rows to the table, we use the \fw{addRow} function and the row +constructor \fw{.|.} to construct rows: + +\begin{haskellcode} + n <- plainText "Name" + ph <- plainText "Phone Number" + addRow tbl $ n .|. ph +\end{haskellcode} + +In the following sections we will go into more detail on the table +API. + +\subsection{Column Specifications: the \fw{ColumnSpec} Type} +\label{sec:columnspecs} + +\fw{newTable}'s column specification list dictates how many terminal +columns the \fw{Table} will have and how they will behave. The column +specification type, \fw{ColumnSpec}, specifies three properties of a +column: + +\begin{itemize} +\item Width -- either a fixed number of columns, \fw{ColFixed}, or + automatically sized, \fw{Col\-Auto}. +\item Alignment -- left-aligned by default. +\item Padding -- no padding by default. +\end{itemize} + +The width of a column dictates how many columns will be allocated to +it at rendering time. A \fw{ColFixed} column will be rendered in the +specified number of columns. A column with a \fw{ColAuto} width will +be allocated a flexible amount of width at rendering time. + +For example, if a \fw{Table} with no borders is rendered in a region +with 80 columns and has two \fw{ColFixed} columns with 10 and 20 +columns respectively and one \fw{ColAuto} column, the \fw{ColAuto} +column will be given $80 - (10 + 20) = 50$ columns of space in the +rendering process. A \fw{Table} may have any number of \fw{ColAuto} +columns; in general, the remaining space is divided evenly between +them. + +The padding and alignment in the \fw{ColumnSpec} serve as the default +properties for each cell in the column unless a cell has overridden +either. + +The \fw{ColumnSpec} type is an instance of the \fw{Paddable} type +class we saw in Section \ref{sec:padding}, so we can specify the +default \fw{Padding} for a column with the \fw{pad} function: + +\begin{haskellcode} + newTable [column ColAuto `pad` (padAll 2)] BorderFull +\end{haskellcode} + +The \fw{ColumnSpec} type is also an instance of the \fw{Alignable} +type class provided by the \fw{Table} module. This type class +provides an \fw{align} function which we can use to set the default +cell alignment for the column: + +\begin{haskellcode} + newTable [column ColAuto `align` AlignRight] BorderFull +\end{haskellcode} + +The \fw{align} function takes an \fw{Alignment} value. Valid values +are \fw{Align\-Left}, \fw{Align\-Center}, and \fw{Align\-Right}. + +\subsection{Border Settings} + +\fw{Table}s support three border configurations using the +\fw{BorderStyle} type. Valid values are as follows: + +\begin{itemize} +\item \fw{BorderNone} -- no borders of any kind. +\item \fw{BorderFull} -- full borders on all sides of the table and in + between all rows and columns. +\item \fw{BorderPartial} -- borders around or in between some elements + of the table; this constructor takes a list of \fw{BorderFlag}s, + whose values are \fw{Rows}, \fw{Columns}, and \fw{Edges}. +\end{itemize} + +A \fw{Table}'s border style cannot be changed once the \fw{Table} has +been created. + +\subsection{Adding Rows} + +The \fw{addRow} function provides a flexible API for adding various +types of values to table cells. The function expects an instance of +the \fw{RowLike} type class. This type class is intended to be +instanced by any type that contains a value that can be embedded in a +table cell. Any \fw{Widget a} is a \fw{RowLike}, so any widget can be +added to a table in a straightforward way: + +\begin{haskellcode} + t <- plainText "foobar" + addRow tbl t +\end{haskellcode} + +In addition, empty cells can be created with the \fw{emptyCell} +function: + +\begin{haskellcode} + addRow tbl emptyCell +\end{haskellcode} + +The above examples work in the case where the \fw{Table} has only one +column; to construct rows for \fw{Table}s with multiple columns, we +use the row constructor, \fw{.|.}, which takes any two \fw{RowLike} +values and constructs a row from them: + +\begin{haskellcode} + t1 <- plainText "foo" + t2 <- plainText "bar" + addRow tbl1 $ t1 .|. t2 -- tbl1 has two columns + + t3 <- plainText "baz" + addRow tbl2 $ t1 .|. t2 .|. t3 -- tbl2 has three columns +\end{haskellcode} + +The only restriction on table cell content is that any widget added to +a table cell \textit{must not grow vertically}. If it does, +\fw{addRow} will throw a \fw{TableError} exception. + +\subsection{Default Cell Alignment and Padding} + +The \fw{Table} stores default cell alignment and padding settings +which apply to all cells in the table. These settings are set with +the following functions: + +\begin{itemize} +\item \fw{setDefaultCellAlignment} -- sets the default \fw{Alignment} + used for all cells in the table. +\item \fw{setDefaultCellPadding} -- sets the default \fw{Padding} + value used for all cells in the table. +\end{itemize} + +We can override these settings on a per-column basis by setting +\fw{Alignment} and \fw{Padding} on the \fw{ColumnSpec} values as we +saw in Section \ref{sec:columnspecs}. + +\begin{haskellcode} + setDefaultCellPadding tbl (padLeft 1) + setDefaultCellAlignment tbl AlignCenter +\end{haskellcode} + +As we will see in the following section, we can even override these +settings on a per-cell basis. + +\subsection{Customizing Cell Alignment and Padding} + +By default, each table cell uses its column's alignment and padding +settings. If the column's \fw{ColumnSpec} has no alignment or padding +settings, the table-wide defaults will be used instead. However, it +is possible to customize these settings on a per-cell basis. + +Every widget in a \fw{Table} is ultimately embedded in the +\fw{TableCell} type. This type holds the widget itself and any +customized alignment and padding settings. The \fw{TableCell} type is +an instance of the \fw{Paddable} and \fw{Alignable} type classes so we +can use the familiar \fw{pad} and \fw{align} functions to pad and +align the \fw{TableCell}. + +To customize a cell's properties, we must first wrap the cell widget +in a \fw{TableCell} with the \fw{customCell} function: + +\begin{haskellcode} + t <- plainText "foobar" + addRow tbl $ customCell t +\end{haskellcode} + +Then we can use \fw{pad} and \fw{align} on the \fw{TableCell}: + +\begin{haskellcode} + t <- plainText "foobar" + addRow tbl $ customCell t `pad` (padAll 1) `align` AlignRight +\end{haskellcode} + +\subsubsection{How Cell Alignment Works} + +Cell alignment determines how remaining space will be used when a +cell's widget is rendered. The default poilcy, \fw{AlignLeft}, +indicates that when a cell's widget is rendered, it will be +right-padded with a space-filling widget so that it takes up enough +on-screen columns to fill the width specified by the \fw{Table}'s +\fw{ColumnSpec}. The \fw{AlignRight} and \fw{AlignCenter} settings +behave similarly. + +What this means is that the alignment settings do not dictate +\textit{how} the contents of each cell are laid out; they only dictate +how the left-over space is used when a cell widget does not fill the +table's column. In most cases this distinction is effectively +unimportant, but in some cases it may be helpful to understand. + +Consider a table cell which contains an \fw{Edit} widget. \fw{Edit} +widgets grow horizontall. Any \fw{Edit} widget placed in a table cell +will always fill it, so alignment settings will not affect the result. +However, if the \fw{Edit} widget is constrained with a ``fixed'' +widget as described in Section \ref{sec:fixed}, if any space is left +over, the widget will be padded according to the alignment setting. + +\subsubsection{Growth Policy} + +\fw{Table}s do not grow vertically but will grow horizontally if they +contain any \fw{ColAuto} columns. diff --git a/doc/ch4/main.tex b/doc/ch4/main.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/main.tex @@ -0,0 +1,31 @@ +\chapter{Guided Tour of Built-In \vtyui\ Widgets} +\label{chap:guided_tour} + +\vtyui\ provides a broad set of widgets for controlling layout, +presenting text, and interacting with the user. In this chapter we'll +cover these built-in widgets and their APIs at a high level. With +this knowledge you should be able to bring them together to build rich +interfaces. As always, consult the API documentation for some of the +finer details. + +Naturally, we may not be able to provide meaningful examples expressed +purely in terms of a single widget type and may need to mention other +widgets; in those cases, see the relevant sections. + +\input{ch4/Borders} +\input{ch4/Box} +\input{ch4/Button} +\input{ch4/CheckBox} +\input{ch4/Collection} +\input{ch4/Dialog} +\input{ch4/DirBrowser} +\input{ch4/Edit} +\input{ch4/FormattedText} +\input{ch4/Centering} +\input{ch4/Fills} +\input{ch4/Fixed} +\input{ch4/Limits} +\input{ch4/List} +\input{ch4/Padded} +\input{ch4/ProgressBar} +\input{ch4/Table} diff --git a/doc/macros.tex b/doc/macros.tex new file mode 100644 --- /dev/null +++ b/doc/macros.tex @@ -0,0 +1,9 @@ +% Custom macros. + +\newcommand{\vtyuiversion}{1.0} + +\newcommand{\fw}[1]{\texttt{#1}} +\newcommand{\vtyui}{\fw{vty-ui}} + +% Defines 'haskellcode' environment to have these options. +\newminted{haskell}{samepage,fontsize=\small} diff --git a/doc/title_page.tex b/doc/title_page.tex new file mode 100644 --- /dev/null +++ b/doc/title_page.tex @@ -0,0 +1,6 @@ +\title{\vtyui\ User's Manual} +\author{ + For \vtyui\ version \vtyuiversion\\ + Jonathan Daugherty (\href{mailto:jtd@galois.com}{jtd@galois.com}) +} +\maketitle diff --git a/doc/toc.tex b/doc/toc.tex new file mode 100644 --- /dev/null +++ b/doc/toc.tex @@ -0,0 +1,2 @@ +\tableofcontents +\newpage diff --git a/doc/vty-ui-users-manual.tex b/doc/vty-ui-users-manual.tex new file mode 100644 --- /dev/null +++ b/doc/vty-ui-users-manual.tex @@ -0,0 +1,37 @@ +\documentclass[11pt, letterpaper, oneside, titlepage]{book} +% Use Palatino fonts. +\renewcommand{\rmdefault}{ppl} +\renewcommand{\ttdefault}{pcr} + +% For smarter references. +\usepackage{varioref} + +% For syntax highlighting! +\usepackage{minted} + +% For hyperlinks. +\usepackage{hyperref} +\hypersetup{colorlinks,citecolor=blue,% + filecolor=red,linkcolor=blue,% + urlcolor=blue} + +% Customize document dimensions. +\addtolength{\hoffset}{-0.5in} +\addtolength{\textwidth}{1.0in} +\setlength{\topmargin}{0in} +\setlength{\parskip}{0.1in} +\setlength{\parindent}{0in} + +\begin{document} + +\include{macros} +\include{title_page} +\include{toc} + +% Chapters. +\include{ch1/main} +\include{ch2/main} +\include{ch3/main} +\include{ch4/main} + +\end{document} diff --git a/src/ComplexDemo.hs b/src/ComplexDemo.hs new file mode 100644 --- /dev/null +++ b/src/ComplexDemo.hs @@ -0,0 +1,164 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} +module Main where + +import System.Exit ( exitSuccess ) +import System.Locale +import Control.Monad +import Control.Concurrent +import Data.Time.Clock +import Data.Time.Format +import Text.Regex.PCRE.Light +import Graphics.Vty +import Graphics.Vty.Widgets.All +import qualified Data.ByteString.Char8 as BS8 + +-- Visual attributes. +fg = white +bg = black +focAttr = black `on` yellow +headerAttr = fgColor bright_green +msgAttr = fgColor blue + +-- Formatter to apply a color to "<...>" +color :: Formatter +color = highlight (compile (BS8.pack "<.*>") []) (fgColor bright_green) + +-- Multi-state checkbox value type +data FrostingType = Chocolate + | Vanilla + | Lemon + deriving (Eq, Show) + +main :: IO () +main = do + let msg = "- switches input elements\n\n\ + \- ordinary keystrokes edit\n\n\ + \- toggles radio buttons and checkboxes\n\n\ + \- quits" + + columns = [ column (ColFixed 25) `pad` (padAll 1) + , column ColAuto `pad` (padAll 1) + ] + + table <- newTable columns BorderFull >>= + withNormalAttribute (bgColor blue) >>= + withBorderAttribute (fgColor green) + + tw <- (textWidget (wrap &.& color) msg) >>= withNormalAttribute msgAttr + mainBox <- vBox table tw >>= withBoxSpacing 1 + + r1 <- newCheckbox "Cake" + r2 <- newCheckbox "Death" + radioHeader <- plainText "" >>= withNormalAttribute headerAttr + + rg <- newRadioGroup + addToRadioGroup rg r1 + addToRadioGroup rg r2 + + r3 <- newMultiStateCheckbox "Frosting" [ (Chocolate, 'C') + , (Vanilla, 'V') + , (Lemon, 'L') + ] + + edit1 <- editWidget >>= withFocusAttribute (white `on` red) + edit2 <- editWidget + + edit1Header <- textWidget wrap "" >>= withNormalAttribute headerAttr + edit2Header <- textWidget wrap "" >>= withNormalAttribute headerAttr + + lst <- newList (fgColor bright_green) plainText + + selector <- vLimit 3 lst + listHeader <- plainText "" + + rs <- vBox r1 r2 + + cbHeader <- plainText "" + timeText <- plainText "" + + prog <- newProgressBar red white + progLabel <- plainText "" + + addHeadingRow_ table headerAttr ["Column 1", "Column 2"] + addRow table $ radioHeader .|. rs + addRow table $ cbHeader .|. r3 + addRow table $ edit1Header .|. edit1 + addRow table $ edit2Header .|. edit2 + addRow table $ listHeader .|. customCell selector `pad` padNone + addRow table $ emptyCell .|. timeText + addRow table $ progLabel .|. (progressBarWidget prog) + + rg `onRadioChange` \cb -> do + s <- getCheckboxLabel cb + setText radioHeader $ s ++ ", please." + + r3 `onCheckboxChange` \v -> + setText cbHeader $ "you chose: " ++ show v + + prog `onProgressChange` \val -> + setText progLabel $ show val ++ " %" + + edit1 `onChange` (setText edit1Header) + edit2 `onChange` (setText edit2Header) + + lst `onSelectionChange` \ev -> + case ev of + SelectionOn _ k _ -> setText listHeader $ "You selected: " ++ k + SelectionOff -> return () + + lst `onItemActivated` \(ActivateItemEvent _ s _) -> + setText listHeader $ "You activated: " ++ s + + setEditText edit1 "Foo" + setEditText edit2 "Bar" + setCheckboxChecked r1 + + setCheckboxState r3 Chocolate + -- It would be nice if we didn't have to do this, but the + -- setCheckboxState call above will not notify any state-change + -- handlers because the state isn't actually changing (from its + -- original value of Chocolate, the first value in its state list). + setText cbHeader $ "you chose: Chocolate" + + fgr <- newFocusGroup + fgr `onKeyPressed` \_ k _ -> do + case k of + KEsc -> exitSuccess + _ -> return False + + mapM_ (addToList lst) [ "Cookies" + , "Cupcakes" + , "Twinkies" + , "M&Ms" + , "Fritos" + , "Cheetos" + ] + + addToFocusGroup fgr r1 + addToFocusGroup fgr r2 + addToFocusGroup fgr r3 + addToFocusGroup fgr edit1 + addToFocusGroup fgr edit2 + addToFocusGroup fgr lst + + ui <- centered =<< hLimit 70 mainBox + + forkIO $ forever $ do + schedule $ do + t <- getCurrentTime + setText timeText $ formatTime defaultTimeLocale rfc822DateFormat t + threadDelay $ 1 * 1000 * 1000 + + forkIO $ forever $ do + let act i = do + threadDelay $ 1 * 1000 * 1000 + schedule $ setProgress prog (i `mod` 101) + act $ i + 4 + act 0 + + c <- newCollection + _ <- addToCollection c ui fgr + + runUi c $ defaultContext { focusAttr = focAttr + , normalAttr = fg `on` bg + } diff --git a/src/Demo.hs b/src/Demo.hs deleted file mode 100644 --- a/src/Demo.hs +++ /dev/null @@ -1,187 +0,0 @@ -module Main where - -import Data.Maybe ( fromJust ) -import Control.Applicative ( (<$>) ) -import Control.Monad ( when ) -import Control.Monad.Trans ( liftIO ) -import Control.Monad.State ( StateT, get, modify, evalStateT ) -import Text.Regex.PCRE.Light.Char8 ( Regex, compile ) - -import Graphics.Vty - ( Event(..), Key(..), Vty, Attr - , mkVty, shutdown, terminal, next_event, reserve_display - , pic_for_image, update, with_fore_color, with_back_color - , def_attr, blue, bright_white, bright_yellow, bright_green - , black, yellow, red - ) -import Graphics.Vty.Widgets.Base - ( (<-->) - , (<++>) - , hFill - ) -import Graphics.Vty.Widgets.Rendering - ( Widget(..) - , mkImage - ) -import Graphics.Vty.Widgets.Text - ( simpleText, wrap, highlight - , prepareText, textWidget, (&.&) - ) -import Graphics.Vty.Widgets.Borders - ( bordered, hBorder - ) -import Graphics.Vty.Widgets.Composed - ( bottomPadded - ) -import Graphics.Vty.Widgets.List - ( List, mkList, pageUp, pageDown, resize - , scrollUp, scrollDown, listWidget, getSelected - , selectedIndex - ) - -titleAttr :: Attr -titleAttr = def_attr - `with_back_color` blue - `with_fore_color` bright_white - -boxAttr :: Attr -boxAttr = def_attr - `with_back_color` black - `with_fore_color` bright_yellow - -bodyAttr :: Attr -bodyAttr = def_attr - `with_back_color` black - `with_fore_color` bright_green - -selAttr :: Attr -selAttr = def_attr - `with_back_color` yellow - `with_fore_color` black - -regex1 :: Regex -regex1 = compile "(to|an|or|too)" [] - -hlAttr1 :: Attr -hlAttr1 = def_attr - `with_back_color` black - `with_fore_color` red - -regex2 :: Regex -regex2 = compile "(text|if|you)" [] - -hlAttr2 :: Attr -hlAttr2 = def_attr - `with_back_color` black - `with_fore_color` yellow - -buildUi :: AppState -> Widget -buildUi appst = - let body = fromJust $ lookup (fst $ getSelected list) msgs - currentItem = selectedIndex list + 1 - footer = (simpleText titleAttr $ " " ++ (show currentItem) ++ "/" ++ (show $ length msgs) ++ " ") - <++> hFill titleAttr '-' 1 - msgs = theMessages appst - list = theList appst - formatter = wrap &.& - highlight regex1 hlAttr1 &.& - highlight regex2 hlAttr2 - in bordered boxAttr $ listWidget list - <--> hBorder titleAttr - <--> (bottomPadded $ textWidget formatter $ prepareText bodyAttr body) - <--> footer - --- Construct the user interface based on the contents of the --- application state. -uiFromState :: StateT AppState IO Widget -uiFromState = buildUi <$> get - --- The application state; this encapsulates what can vary based on --- user input and what is used to construct the interface. This is a --- place for widgets whose state need to be stored so they can be --- modified and used to reconstruct the interface as input is handled -data AppState = AppState { theList :: List String - , theMessages :: [(String, String)] - } - -scrollListUp :: AppState -> AppState -scrollListUp appst = appst { theList = scrollUp $ theList appst } - -scrollListDown :: AppState -> AppState -scrollListDown appst = appst { theList = scrollDown $ theList appst } - -pageListUp :: AppState -> AppState -pageListUp appst = appst { theList = pageUp $ theList appst } - -pageListDown :: AppState -> AppState -pageListDown appst = appst { theList = pageDown $ theList appst } - -resizeList :: Int -> AppState -> AppState -resizeList s appst = appst { theList = resize s $ theList appst } - --- Process events from VTY, possibly modifying the application state. -eventloop :: Vty - -> StateT AppState IO Widget - -> (Event -> StateT AppState IO Bool) - -> StateT AppState IO () -eventloop vty uiBuilder handle = do - w <- uiBuilder - evt <- liftIO $ do - (img, _) <- mkImage vty w - update vty $ pic_for_image img - next_event vty - next <- handle evt - if next then - eventloop vty uiBuilder handle else - return () - -continue :: StateT AppState IO Bool -continue = return True - -stop :: StateT AppState IO Bool -stop = return False - -handleEvent :: Event -> StateT AppState IO Bool -handleEvent (EvKey KUp []) = modify scrollListUp >> continue -handleEvent (EvKey KDown []) = modify scrollListDown >> continue -handleEvent (EvKey KPageUp []) = modify pageListUp >> continue -handleEvent (EvKey KPageDown []) = modify pageListDown >> continue -handleEvent (EvKey (KASCII 'q') []) = stop -handleEvent (EvResize _ h) = do - let newSize = ceiling ((0.05 :: Double) * fromIntegral h) - when (newSize > 0) $ modify (resizeList newSize) - continue -handleEvent _ = continue - --- Construct the application state using the message map. -mkAppState :: [(String, String)] -> AppState -mkAppState messages = - let list = mkList bodyAttr selAttr 5 labelWidgets - labelWidgets = zip labels $ map mkWidget labels - mkWidget = simpleText bodyAttr - labels = map fst messages - in AppState { theList = list - , theMessages = messages - } - -main :: IO () -main = do - vty <- mkVty - - -- The data that we'll present in the interface. - let messages = [ ("First", "This text is long enough that it will get wrapped \ - \if you resize your terminal to something small. \ - \It also contains enough text to get truncated at \ - \the bottom if the display area is too small.\n\n\n" ) - , ("Second", "the second message") - , ("Third", "the third message") - , ("Fourth", "the fourth message") - , ("Fifth", "the fifth message") - , ("Sixth", "the sixth message") - , ("Seventh", "the seventh message") - ] - - evalStateT (eventloop vty uiFromState handleEvent) $ mkAppState messages - -- Clear the screen. - reserve_display $ terminal vty - shutdown vty diff --git a/src/DialogDemo.hs b/src/DialogDemo.hs new file mode 100644 --- /dev/null +++ b/src/DialogDemo.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Main where + +import System.Exit +import Graphics.Vty hiding (Button) +import Graphics.Vty.Widgets.All + +main :: IO () +main = do + e <- editWidget + fg <- newFocusGroup + addToFocusGroup fg e + + u <- plainText "Enter some text and press enter." <--> return e + >>= withBoxSpacing 1 + + pe <- padded u (padLeftRight 2) + (d, dFg) <- newDialog pe "" + setNormalAttribute d (white `on` blue) + + c <- centered =<< withPadding (padLeftRight 10) (dialogWidget d) + + -- When the edit widget changes, set the dialog's title. + e `onChange` setDialogTitle d + + -- When the user presses Enter in the edit widget, accept the + -- dialog. + e `onActivate` (const $ acceptDialog d) + + -- Exit either way. + d `onDialogAccept` const exitSuccess + d `onDialogCancel` const exitSuccess + + coll <- newCollection + _ <- addToCollection coll c =<< (mergeFocusGroups fg dFg) + + runUi coll $ defaultContext { focusAttr = black `on` yellow } diff --git a/src/DirBrowserDemo.hs b/src/DirBrowserDemo.hs new file mode 100644 --- /dev/null +++ b/src/DirBrowserDemo.hs @@ -0,0 +1,17 @@ +module Main where + +import Graphics.Vty +import Graphics.Vty.Widgets.All + +main :: IO () +main = do + (b, fg) <- newDirBrowser defaultBrowserSkin + + c <- newCollection + _ <- addToCollection c (dirBrowserWidget b) fg + + b `onBrowseAccept` error + b `onBrowseCancel` error + + runUi c $ defaultContext { focusAttr = white `on` blue + } diff --git a/src/Graphics/Vty/Widgets/All.hs b/src/Graphics/Vty/Widgets/All.hs --- a/src/Graphics/Vty/Widgets/All.hs +++ b/src/Graphics/Vty/Widgets/All.hs @@ -1,17 +1,47 @@ -- |A convenience module exporting everything in this library. module Graphics.Vty.Widgets.All - ( module Graphics.Vty.Widgets.Rendering - , module Graphics.Vty.Widgets.Base + ( module Graphics.Vty.Widgets.EventLoop + , module Graphics.Vty.Widgets.Core + , module Graphics.Vty.Widgets.Box , module Graphics.Vty.Widgets.List - , module Graphics.Vty.Widgets.Composed , module Graphics.Vty.Widgets.Borders , module Graphics.Vty.Widgets.Text + , module Graphics.Vty.Widgets.Edit + , module Graphics.Vty.Widgets.Util + , module Graphics.Vty.Widgets.Table + , module Graphics.Vty.Widgets.CheckBox + , module Graphics.Vty.Widgets.Padding + , module Graphics.Vty.Widgets.Limits + , module Graphics.Vty.Widgets.Fixed + , module Graphics.Vty.Widgets.Fills + , module Graphics.Vty.Widgets.Centering + , module Graphics.Vty.Widgets.Skins + , module Graphics.Vty.Widgets.Events + , module Graphics.Vty.Widgets.Dialog + , module Graphics.Vty.Widgets.Button + , module Graphics.Vty.Widgets.ProgressBar + , module Graphics.Vty.Widgets.DirBrowser ) where -import Graphics.Vty.Widgets.Rendering -import Graphics.Vty.Widgets.Base +import Graphics.Vty.Widgets.EventLoop +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Box import Graphics.Vty.Widgets.List -import Graphics.Vty.Widgets.Composed import Graphics.Vty.Widgets.Borders import Graphics.Vty.Widgets.Text +import Graphics.Vty.Widgets.Edit +import Graphics.Vty.Widgets.Util +import Graphics.Vty.Widgets.Table +import Graphics.Vty.Widgets.CheckBox +import Graphics.Vty.Widgets.Padding +import Graphics.Vty.Widgets.Limits +import Graphics.Vty.Widgets.Fixed +import Graphics.Vty.Widgets.Fills +import Graphics.Vty.Widgets.Centering +import Graphics.Vty.Widgets.Skins +import Graphics.Vty.Widgets.Events +import Graphics.Vty.Widgets.Dialog +import Graphics.Vty.Widgets.Button +import Graphics.Vty.Widgets.ProgressBar +import Graphics.Vty.Widgets.DirBrowser diff --git a/src/Graphics/Vty/Widgets/Base.hs b/src/Graphics/Vty/Widgets/Base.hs deleted file mode 100644 --- a/src/Graphics/Vty/Widgets/Base.hs +++ /dev/null @@ -1,170 +0,0 @@ --- |A collection of primitive user interface widgets for composing and --- laying out 'Graphics.Vty' user interfaces. This module provides --- basic static and box layout widgets. -module Graphics.Vty.Widgets.Base - ( (<++>) - , (<-->) - , hBox - , vBox - , hFill - , vFill - , hLimit - , vLimit - ) -where - -import GHC.Word ( Word ) - -import Graphics.Vty.Widgets.Rendering - ( Widget(..) - , Render - , renderImg - , renderMany - , renderWidth - , renderHeight - , Orientation(..) - , withHeight - , withWidth - ) -import Graphics.Vty - ( DisplayRegion - , Attr - , char_fill - , region_width - , region_height - ) - --- |A vertical fill widget. Fills all available space with the --- specified character and attribute. -vFill :: Attr -> Char -> Widget -vFill att c = Widget { - growHorizontal = False - , growVertical = True - , primaryAttribute = att - , withAttribute = flip vFill c - , render = \s -> renderImg $ char_fill att c (region_width s) - (region_height s) - } - --- |A horizontal fill widget. Fills the available horizontal space, --- one row high, using the specified character and attribute. -hFill :: Attr -> Char -> Int -> Widget -hFill att c h = Widget { - growHorizontal = True - , growVertical = False - , primaryAttribute = att - , withAttribute = \att' -> hFill att' c h - , render = \s -> renderImg $ char_fill att c (region_width s) - (toEnum h) - } - --- |A box layout widget capable of containing two 'Widget's --- horizontally or vertically. See 'hBox' and 'vBox'. Boxes lay out --- their children by using the growth properties of the children: --- --- * If both children are expandable in the same dimension (i.e., both --- vertically or both horizontally), the children are each given --- half of the parent container's available space --- --- * If one of the children is expandable and the other is static, the --- static child is rendered first and the remaining space is given --- to the expandable child --- --- * Otherwise, both children are rendered in top-to-bottom or --- left-to-right order and the resulting container uses only as much --- space as its children combined -box :: Orientation -> Widget -> Widget -> Widget -box o a b = Widget { - growHorizontal = growHorizontal a || growHorizontal b - , growVertical = growVertical a || growVertical b - , withAttribute = - \att -> - box o (withAttribute a att) (withAttribute b att) - , primaryAttribute = primaryAttribute a - , render = - \s -> case o of - Vertical -> - renderBox s (a, b) o growVertical region_height - renderHeight withHeight - Horizontal -> - renderBox s (a, b) o growHorizontal region_width - renderWidth withWidth - } - --- Box layout rendering implementation. This is generalized over the --- two dimensions in which box layout can be performed; it takes lot --- of functions, but mostly those are to query and update the correct --- dimensions on regions and images as they are manipulated by the --- layout algorithm. -renderBox :: DisplayRegion - -> (Widget, Widget) - -> Orientation - -> (Widget -> Bool) -- growth comparison function - -> (DisplayRegion -> Word) -- region dimension fetch function - -> (Render -> Word) -- image dimension fetch function - -> (DisplayRegion -> Word -> DisplayRegion) -- dimension modification function - -> Render -renderBox s (first, second) orientation grow regDimension renderDimension withDim = - renderMany orientation ws - where - ws = case (grow first, grow second) of - (True, True) -> renderHalves - (False, _) -> renderOrdered first second - (_, False) -> let [a, b] = renderOrdered second first - in [b, a] - renderHalves = let half = s `withDim` div (regDimension s) 2 - half' = if regDimension s `mod` 2 == 0 - then half - else half `withDim` (regDimension half + 1) - in [ render first half - , render second half' ] - renderOrdered a b = let renderedA = render a s - renderedB = render b s' - remaining = regDimension s - renderDimension renderedA - s' = s `withDim` remaining - in if renderDimension renderedA >= regDimension s - then [renderedA] - else [renderedA, renderedB] - --- |Create a horizontal box layout widget containing two widgets side --- by side. Space consumed by the box will depend on its contents and --- the available space. -hBox :: Widget -> Widget -> Widget -hBox = box Horizontal - --- |An alias for 'hBox' intended as sugar to chain widgets --- horizontally. -(<++>) :: Widget -> Widget -> Widget -(<++>) = hBox - --- |Create a vertical box layout widget containing two widgets. Space --- consumed by the box will depend on its contents and the available --- space. -vBox :: Widget -> Widget -> Widget -vBox = box Vertical - --- |An alias for 'vBox' intended as sugar to chain widgets vertically. -(<-->) :: Widget -> Widget -> Widget -(<-->) = vBox - --- |Impose a maximum horizontal size, in columns, on a 'Widget'. -hLimit :: Int -> Widget -> Widget -hLimit maxWidth w = w { growHorizontal = False - , render = restrictedRender - } - where - restrictedRender sz = - if region_width sz < fromIntegral maxWidth - then render w sz - else render w $ sz `withWidth` fromIntegral maxWidth - --- |Impose a maximum vertical size, in rows, on a 'Widget'. -vLimit :: Int -> Widget -> Widget -vLimit maxHeight w = w { growVertical = False - , render = restrictedRender - } - where - restrictedRender sz = - if region_height sz < fromIntegral maxHeight - then render w sz - else render w $ sz `withHeight` fromIntegral maxHeight diff --git a/src/Graphics/Vty/Widgets/Borders.hs b/src/Graphics/Vty/Widgets/Borders.hs --- a/src/Graphics/Vty/Widgets/Borders.hs +++ b/src/Graphics/Vty/Widgets/Borders.hs @@ -1,90 +1,205 @@ +{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances #-} -- |This module provides visual borders to be placed between and --- around widgets. +-- around widgets. Border widgets in this module use the active +-- 'Skin' in the 'RenderContext'. module Graphics.Vty.Widgets.Borders - ( vBorder + ( HasBorderAttr(..) + , Bordered + , HBorder + , VBorder + -- * Border Widget Constructors + , vBorder , hBorder - , vBorderWith - , hBorderWith , bordered + -- * Setting Attributes and Labels + , withBorderAttribute + , withHBorderLabel + , withBorderedLabel + , setHBorderLabel + , setBorderedLabel ) where +import Control.Monad.Trans import Graphics.Vty - ( Attr - , DisplayRegion(DisplayRegion) - , char_fill - , region_height - , region_width - ) -import Graphics.Vty.Widgets.Rendering - ( Widget(..) - , Render - , Orientation(..) - , renderImg - , renderMany - , renderWidth - , renderHeight - ) -import Graphics.Vty.Widgets.Base - ( (<++>) - ) +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Box import Graphics.Vty.Widgets.Text - ( simpleText - ) +import Graphics.Vty.Widgets.Util +import Graphics.Vty.Widgets.Skins --- |Create a single-row horizontal border. -hBorder :: Attr -> Widget -hBorder = hBorderWith '-' +-- |The class of types with a border attribute, which differs from the +-- |normal and focused attributes. +class HasBorderAttr a where + setBorderAttribute :: (MonadIO m) => a -> Attr -> m () +data HBorder = HBorder Attr String + deriving (Show) + +instance HasBorderAttr (Widget HBorder) where + setBorderAttribute t a = + updateWidgetState t $ \(HBorder a' s) -> HBorder (mergeAttr a a') s + +withBorderAttribute :: (MonadIO m, HasBorderAttr a) => Attr -> a -> m a +withBorderAttribute att w = setBorderAttribute w att >> return w + +withHBorderLabel :: (MonadIO m) => String -> Widget HBorder -> m (Widget HBorder) +withHBorderLabel label w = setHBorderLabel w label >> return w + +setHBorderLabel :: (MonadIO m) => Widget HBorder -> String -> m () +setHBorderLabel w label = + updateWidgetState w $ \(HBorder a _) -> HBorder a label + +withBorderedLabel :: (MonadIO m) => String -> Widget (Bordered a) -> m (Widget (Bordered a)) +withBorderedLabel label w = setBorderedLabel w label >> return w + +setBorderedLabel :: (MonadIO m) => Widget (Bordered a) -> String -> m () +setBorderedLabel w label = + updateWidgetState w $ \(Bordered a ch _) -> Bordered a ch label + -- |Create a single-row horizontal border using the specified -- attribute and character. -hBorderWith :: Char -> Attr -> Widget -hBorderWith ch att = - Widget { growVertical = False - , growHorizontal = True - , primaryAttribute = att - , withAttribute = hBorder - , render = \s -> renderImg $ char_fill att ch (region_width s) 1 - } +hBorder :: (MonadIO m) => m (Widget HBorder) +hBorder = do + wRef <- newWidget $ \w -> + w { state = HBorder def_attr "" + , growHorizontal_ = const $ return True + , render_ = renderHBorder + } + return wRef --- |Create a single-column vertical border. -vBorder :: Attr -> Widget -vBorder = vBorderWith '|' +renderHBorder :: Widget HBorder -> DisplayRegion -> RenderContext -> IO Image +renderHBorder _ (DisplayRegion 0 _) _ = return empty_image +renderHBorder _ (DisplayRegion _ 0) _ = return empty_image +renderHBorder this s ctx = do + HBorder attr str <- getState this + let attr' = mergeAttrs [ overrideAttr ctx + , attr + , normalAttr ctx + ] + noTitle = char_fill attr' (skinHorizontal $ skin ctx) (region_width s) 1 + case null str of + True -> return noTitle + False -> do + let title = " " ++ str ++ " " + case (toEnum $ length title) > region_width s of + True -> return noTitle + False -> do + let remaining = region_width s - (toEnum $ length title) + side1 = remaining `div` 2 + side2 = if remaining `mod` 2 == 0 then side1 else side1 + 1 + return $ horiz_cat [ char_fill attr' (skinHorizontal $ skin ctx) side1 1 + , string attr' title + , char_fill attr' (skinHorizontal $ skin ctx) side2 1 + ] +data VBorder = VBorder Attr + deriving (Show) + +instance HasBorderAttr (Widget VBorder) where + setBorderAttribute t a = + updateWidgetState t $ \(VBorder a') -> VBorder (mergeAttr a a') + -- |Create a single-column vertical border using the specified -- attribute and character. -vBorderWith :: Char -> Attr -> Widget -vBorderWith ch att = - Widget { growHorizontal = False - , growVertical = True - , primaryAttribute = att - , render = \s -> renderImg $ char_fill att ch 1 (region_height s) - , withAttribute = vBorder - } +vBorder :: (MonadIO m) => m (Widget VBorder) +vBorder = do + wRef <- newWidget $ \w -> + w { state = VBorder def_attr + , growVertical_ = const $ return True + , render_ = \this s ctx -> do + VBorder attr <- getState this + let attr' = mergeAttrs [ overrideAttr ctx + , attr + , normalAttr ctx + ] + return $ char_fill attr' (skinVertical $ skin ctx) 1 (region_height s) + } + return wRef --- |Wrap a widget in a bordering box using the specified attribute. -bordered :: Attr -> Widget -> Widget -bordered att w = Widget { - growVertical = growVertical w - , growHorizontal = growHorizontal w - , primaryAttribute = att - , withAttribute = \att' -> bordered att' (withAttribute w att') - , render = renderBordered att w - } +data Bordered a = (Show a) => Bordered Attr (Widget a) String -renderBordered :: Attr -> Widget -> DisplayRegion -> Render -renderBordered att w s = - -- Render the contained widget with enough room to draw borders. - -- Then, use the size of the rendered widget to constrain the - -- space used by the (expanding) borders. - renderMany Vertical [topBottom, middle, topBottom] - where - constrained = DisplayRegion (region_width s - 2) (region_height s - 2) - renderedChild = render w constrained - adjusted = DisplayRegion - (renderWidth renderedChild + 2) - (renderHeight renderedChild) - corner = simpleText att "+" - topBottom = render (corner <++> hBorder att <++> corner) adjusted - leftRight = render (vBorder att) adjusted - middle = renderMany Horizontal [leftRight, renderedChild, leftRight] +instance Show (Bordered a) where + show (Bordered attr _ l) = concat [ "Bordered { attr = " + , show attr + , ", label = " + , show l + , ", ... }" + ] + +instance HasBorderAttr (Widget (Bordered a)) where + setBorderAttribute t a = + updateWidgetState t $ \(Bordered a' ch s) -> Bordered (mergeAttr a a') ch s + +-- |Wrap a widget in a bordering box. +bordered :: (MonadIO m, Show a) => Widget a -> m (Widget (Bordered a)) +bordered child = do + wRef <- newWidget $ \w -> + w { state = Bordered def_attr child "" + + , growVertical_ = const $ growVertical child + , growHorizontal_ = const $ growHorizontal child + + , keyEventHandler = + \this key mods -> do + Bordered _ ch _ <- getState this + handleKeyEvent ch key mods + + , render_ = + \this s ctx -> do + st <- getState this + drawBordered st s ctx + + , setCurrentPosition_ = + \this pos -> do + Bordered _ ch _ <- getState this + let chPos = pos `plusWidth` 1 `plusHeight` 1 + setCurrentPosition ch chPos + } + wRef `relayFocusEvents` child + wRef `relayKeyEvents` child + return wRef + +drawBordered :: (Show a) => + Bordered a -> DisplayRegion -> RenderContext -> IO Image +drawBordered this s ctx = do + let Bordered attr child label = this + attr' = mergeAttrs [ overrideAttr ctx + , attr + , normalAttr ctx + ] + sk = skin ctx + + -- Render the contained widget with enough room to draw borders. + -- Then, use the size of the rendered widget to constrain the space + -- used by the (expanding) borders. + let constrained = DisplayRegion (region_width s - 2) (region_height s - 2) + + childImage <- render child constrained ctx + + let adjusted = DisplayRegion (image_width childImage + 2) + (image_height childImage) + + tlCorner <- plainText [skinCornerTL sk] >>= withNormalAttribute attr' + trCorner <- plainText [skinCornerTR sk] >>= withNormalAttribute attr' + blCorner <- plainText [skinCornerBL sk] >>= withNormalAttribute attr' + brCorner <- plainText [skinCornerBR sk] >>= withNormalAttribute attr' + + hb <- hBorder >>= withHBorderLabel label + setBorderAttribute hb attr' + + topWidget <- hBox tlCorner =<< hBox hb trCorner + top <- render topWidget adjusted ctx + + hb2 <- hBorder + bottomWidget <- hBox blCorner =<< hBox hb2 brCorner + bottom <- render bottomWidget adjusted ctx + + vb <- vBorder + setBorderAttribute vb attr' + + leftRight <- render vb adjusted ctx + + let middle = horiz_cat [leftRight, childImage, leftRight] + + return $ vert_cat [top, middle, bottom] diff --git a/src/Graphics/Vty/Widgets/Box.hs b/src/Graphics/Vty/Widgets/Box.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Box.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- |This module provides vertical and horizontal box layout widgets +-- using the 'Box' type. Box widgets use their child widgets' size +-- policies and their space allocation settings to determine layout. +-- +-- Box widgets propagate key and focus events to their children. +-- +-- For more details, see the Vty-ui User's Manual. +module Graphics.Vty.Widgets.Box + ( Box + , ChildSizePolicy(..) + , IndividualPolicy(..) + , BoxError(..) + -- * Box Constructors + , hBox + , vBox + , (<++>) + , (<-->) + -- * Box Configuration + , setBoxSpacing + , withBoxSpacing + , defaultChildSizePolicy + , setBoxChildSizePolicy + , getBoxChildSizePolicy + -- * Child Widget References + , getFirstChild + , getSecondChild + ) +where + +import GHC.Word ( Word ) +import Data.Typeable +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty.Widgets.Core +import Graphics.Vty +import Graphics.Vty.Widgets.Util + +data BoxError = BadPercentage + -- ^Indicates that a given percentage value was + -- invalid. + deriving (Eq, Show, Typeable) + +instance Exception BoxError + +data Orientation = Horizontal | Vertical + deriving (Eq, Show) + +-- |Individual child widget policy applied to a child widget contained +-- in a box. +data IndividualPolicy = BoxAuto + -- ^The child's growth policy will be used to + -- determine layout. The child widget layout + -- will also be affected by the policy of the + -- other widget in the box. + | BoxFixed Int + -- ^A fixed number of rows or columns, + -- depending on box type, will be allocated to + -- the child. + deriving (Show, Eq) + +-- |Child size policy applied to a box. +data ChildSizePolicy = PerChild IndividualPolicy IndividualPolicy + -- ^A per-child policy. + | Percentage Int + -- ^Percentage, p, of space given to first + -- child, which implies that (100 - p) percent + -- given to the second. + deriving (Show, Eq) + +data Box a b = Box { boxChildSizePolicy :: ChildSizePolicy + , boxOrientation :: Orientation + , boxSpacing :: Int + , boxFirst :: Widget a + , boxSecond :: Widget b + + -- Box layout functions + + -- growth comparison function + , firstGrows :: IO Bool + -- growth comparison function + , secondGrows :: IO Bool + -- region dimension fetch function + , regDimension :: DisplayRegion -> Word + -- image dimension fetch function + , imgDimension :: Image -> Word + -- dimension modification function + , withDimension :: DisplayRegion -> Word -> DisplayRegion + -- Oriented image concatenation + , img_cat :: [Image] -> Image + } + +instance Show (Box a b) where + show b = concat [ "Box { spacing = ", show $ boxSpacing b + , ", childSizePolicy = ", show $ boxChildSizePolicy b + , ", orientation = ", show $ boxOrientation b + , " }" + ] + +-- |Create a horizontal box widget containing two widgets side by +-- side. Space consumed by the box will depend on its contents, +-- available space, and the box child size policy. +hBox :: (MonadIO m, Show a, Show b) => Widget a -> Widget b -> m (Widget (Box a b)) +hBox = box Horizontal 0 + +-- |Create a vertical box widget containing two widgets, one above the +-- other. Space consumed by the box will depend on its contents, +-- available space, and the box child size policy. +vBox :: (MonadIO m, Show a, Show b) => Widget a -> Widget b -> m (Widget (Box a b)) +vBox = box Vertical 0 + +-- |Create a vertical box widget using monadic widget constructors. +(<-->) :: (MonadIO m, Show a, Show b) => m (Widget a) -> m (Widget b) -> m (Widget (Box a b)) +(<-->) act1 act2 = do + ch1 <- act1 + ch2 <- act2 + vBox ch1 ch2 + +-- |Create a horizontal box widget using monadic widget constructors. +(<++>) :: (MonadIO m, Show a, Show b) => m (Widget a) -> m (Widget b) -> m (Widget (Box a b)) +(<++>) act1 act2 = do + ch1 <- act1 + ch2 <- act2 + hBox ch1 ch2 + +infixl 3 <--> +infixl 3 <++> + +-- |The default box child size policy, which defers to the children to +-- determine layout. +defaultChildSizePolicy :: ChildSizePolicy +defaultChildSizePolicy = PerChild BoxAuto BoxAuto + +box :: (MonadIO m, Show a, Show b) => + Orientation -> Int -> Widget a -> Widget b -> m (Widget (Box a b)) +box o spacing wa wb = do + wRef <- newWidget $ \w -> + w { state = Box { boxChildSizePolicy = defaultChildSizePolicy + , boxOrientation = o + , boxSpacing = spacing + , boxFirst = wa + , boxSecond = wb + + , firstGrows = + (if o == Vertical then growVertical else growHorizontal) wa + , secondGrows = + (if o == Vertical then growVertical else growHorizontal) wb + , regDimension = + if o == Vertical then region_height else region_width + , imgDimension = + if o == Vertical then image_height else image_width + , withDimension = + if o == Vertical then withHeight else withWidth + , img_cat = + if o == Vertical then vert_cat else horiz_cat + } + , growHorizontal_ = \b -> do + case boxOrientation b of + Vertical -> do + h1 <- growHorizontal $ boxFirst b + h2 <- growHorizontal $ boxSecond b + return $ h1 || h2 + Horizontal -> do + case boxChildSizePolicy b of + Percentage _ -> return True + PerChild s1 s2 -> do + h1 <- growHorizontal $ boxFirst b + h2 <- growHorizontal $ boxSecond b + return $ (h1 && s1 == BoxAuto) || (h2 && s2 == BoxAuto) + + , growVertical_ = \b -> do + case boxOrientation b of + Horizontal -> do + h1 <- growVertical $ boxFirst b + h2 <- growVertical $ boxSecond b + return $ h1 || h2 + Vertical -> do + case boxChildSizePolicy b of + Percentage _ -> return True + PerChild s1 s2 -> do + h1 <- growVertical $ boxFirst b + h2 <- growVertical $ boxSecond b + return $ (h1 && s1 == BoxAuto) || (h2 && s2 == BoxAuto) + + , keyEventHandler = + \this key mods -> do + b <- getState this + handled <- handleKeyEvent (boxFirst b) key mods + if handled then return True else + handleKeyEvent (boxSecond b) key mods + + , render_ = \this s ctx -> do + b <- getState this + renderBox s ctx b + + , setCurrentPosition_ = + \this pos -> do + b <- getState this + ch1_size <- getCurrentSize $ boxFirst b + setCurrentPosition (boxFirst b) pos + case boxOrientation b of + Horizontal -> setCurrentPosition (boxSecond b) $ + pos `plusWidth` ((region_width ch1_size) + (toEnum $ boxSpacing b)) + Vertical -> setCurrentPosition (boxSecond b) $ + pos `plusHeight` ((region_height ch1_size) + (toEnum $ boxSpacing b)) + } + + wRef `relayFocusEvents` wa + wRef `relayFocusEvents` wb + + return wRef + +getFirstChild :: (MonadIO m) => Widget (Box a b) -> m (Widget a) +getFirstChild = (boxFirst <~~) + +getSecondChild :: (MonadIO m) => Widget (Box a b) -> m (Widget b) +getSecondChild = (boxSecond <~~) + +-- |Set the spacing in between a box's child widgets in rows or +-- columns, depending on the box type. +setBoxSpacing :: (MonadIO m) => Widget (Box a b) -> Int -> m () +setBoxSpacing wRef spacing = + updateWidgetState wRef $ \b -> b { boxSpacing = spacing } + +withBoxSpacing :: (MonadIO m) => Int -> Widget (Box a b) -> m (Widget (Box a b)) +withBoxSpacing spacing wRef = do + setBoxSpacing wRef spacing + return wRef + +getBoxChildSizePolicy :: (MonadIO m) => Widget (Box a b) -> m ChildSizePolicy +getBoxChildSizePolicy = (boxChildSizePolicy <~~) + +-- |Set the box child size policy. Throws 'BadPercentage' if the size +-- |policy uses an invalid percentage value, which must be between 0 +-- |and 100 inclusive. +setBoxChildSizePolicy :: (MonadIO m) => Widget (Box a b) -> ChildSizePolicy -> m () +setBoxChildSizePolicy b spol = do + case spol of + Percentage v -> when (v < 0 || v > 100) $ throw BadPercentage + _ -> return () + + updateWidgetState b $ \s -> s { boxChildSizePolicy = spol } + +-- Box layout rendering implementation. This is generalized over the +-- two dimensions in which box layout can be performed; it takes lot +-- of functions, but mostly those are to query and update the correct +-- dimensions on regions and images as they are manipulated by the +-- layout algorithm. +renderBox :: (Show a, Show b) => + DisplayRegion + -> RenderContext + -> Box a b + -> IO Image +renderBox s ctx this = do + let actualSpace = regDimension this s - (toEnum (boxSpacing this)) + + (img1, img2) <- + -- XXX fix for case where we don't have enough space to honor + -- hard-coded sizes (either fixed or derived fixed) + + -- XXX also check for overflow + case boxChildSizePolicy this of + PerChild BoxAuto BoxAuto -> renderBoxAuto s ctx this + Percentage v -> do + let firstDim = round (fromRational + (fromRational ((toRational v) / (100.0)) * + (toRational actualSpace)) ::Rational) + secondDim = fromEnum (actualSpace - firstDim) + renderBoxFixed s ctx this (fromEnum firstDim) secondDim + PerChild BoxAuto (BoxFixed v) -> do + let remaining = fromEnum (actualSpace - toEnum v) + renderBoxFixed s ctx this remaining v + PerChild (BoxFixed v) BoxAuto -> do + let remaining = fromEnum (actualSpace - toEnum v) + renderBoxFixed s ctx this v remaining + PerChild (BoxFixed v1) (BoxFixed v2) -> renderBoxFixed s ctx this v1 v2 + + let spAttr = getNormalAttr ctx + spacing = boxSpacing this + spacer = case spacing of + 0 -> empty_image + _ -> case boxOrientation this of + Horizontal -> let h = max (image_height img1) (image_height img2) + in char_fill spAttr ' ' (toEnum spacing) h + Vertical -> let w = max (image_width img1) (image_width img2) + in char_fill spAttr ' ' w (toEnum spacing) + + -- Use the larger of the two images to determine padding in the + -- opposite dimension. E.g. if this is a vertical box, we want + -- to pad the images such that they have the same width. + common_opposite_dim = case boxOrientation this of + Horizontal -> max (image_height img1) (image_height img2) + Vertical -> max (image_width img1) (image_width img2) + + padded_img1 = case boxOrientation this of + Horizontal -> img1 <-> + (char_fill spAttr ' ' (image_width img1) + (common_opposite_dim - image_height img1)) + Vertical -> img1 <|> + (char_fill spAttr ' ' (common_opposite_dim - image_width img1) + (image_height img1)) + padded_img2 = case boxOrientation this of + Horizontal -> img2 <-> + (char_fill spAttr ' ' (image_width img2) + (common_opposite_dim - image_height img2)) + Vertical -> img2 <|> + (char_fill spAttr ' ' (common_opposite_dim - image_width img2) + (image_height img2)) + + + return $ (img_cat this) [padded_img1, spacer, padded_img2] + +renderBoxFixed :: (Show a, Show b) => + DisplayRegion + -> RenderContext + -> Box a b + -> Int + -> Int + -> IO (Image, Image) +renderBoxFixed s ctx this firstDim secondDim = do + let withDim = withDimension this + img1 <- render (boxFirst this) (s `withDim` (toEnum firstDim)) ctx + img2 <- render (boxSecond this) (s `withDim` (toEnum secondDim)) ctx + + -- pad the images so they fill the space appropriately. + let fill img amt = case boxOrientation this of + Vertical -> char_fill (getNormalAttr ctx) ' ' (image_width img) amt + Horizontal -> char_fill (getNormalAttr ctx) ' ' amt (image_height img) + firstDimW = toEnum firstDim + secondDimW = toEnum secondDim + img1_size = (imgDimension this) img1 + img2_size = (imgDimension this) img2 + img1_padded = if img1_size < firstDimW + then (img_cat this) [img1, fill img1 (firstDimW - img1_size)] + else img1 + img2_padded = if img2_size < secondDimW + then (img_cat this) [img2, fill img2 (secondDimW - img2_size)] + else img2 + + return (img1_padded, img2_padded) + +renderBoxAuto :: (Show a, Show b) => + DisplayRegion + -> RenderContext + -> Box a b + -> IO (Image, Image) +renderBoxAuto s ctx this = do + let spacing = boxSpacing this + first = boxFirst this + second = boxSecond this + withDim = withDimension this + renderDimension = imgDimension this + regDim = regDimension this + + actualSpace = s `withDim` (max (regDim s - toEnum spacing) 0) + + renderOrdered a b = do + a_img <- render a actualSpace ctx + + let remaining = regDim actualSpace - renderDimension a_img + s' = actualSpace `withDim` remaining + + b_img <- render b s' ctx + + return $ if renderDimension a_img >= regDim actualSpace + then [a_img, empty_image] + else [a_img, b_img] + + renderHalves = do + let half = actualSpace `withDim` div (regDim actualSpace) 2 + half' = if regDim actualSpace `mod` 2 == 0 + then half + else half `withDim` (regDim half + 1) + first_img <- render first half ctx + second_img <- render second half' ctx + return [first_img, second_img] + + gf <- firstGrows this + gs <- secondGrows this + + [img1, img2] <- case (gf, gs) of + (True, True) -> renderHalves + (False, _) -> renderOrdered first second + (_, False) -> do + images <- renderOrdered second first + return $ reverse images + + return (img1, img2) diff --git a/src/Graphics/Vty/Widgets/Button.hs b/src/Graphics/Vty/Widgets/Button.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Button.hs @@ -0,0 +1,68 @@ +-- |This module provides a ''button'' widget type which has a +-- button-like appearance and generates ''press'' events. 'Button's +-- are pressed when a user presses Enter while the button has focus. +module Graphics.Vty.Widgets.Button + ( Button + , newButton + , buttonWidget + , onButtonPressed + , pressButton + , setButtonText + ) +where + +import Control.Monad.Trans +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Text +import Graphics.Vty.Widgets.Padding +import Graphics.Vty.Widgets.Events +import Graphics.Vty.Widgets.Util +import Graphics.Vty hiding (Button) + +data Button = Button { buttonWidget :: Widget Padded + -- ^Get a reference to the button's widget to lay + -- it out. + , buttonText :: Widget FormattedText + , buttonPressedHandlers :: Handlers Button + } + +-- |Register a handler for the button press event. +onButtonPressed :: (MonadIO m) => Button -> (Button -> IO ()) -> m () +onButtonPressed = addHandler (return . buttonPressedHandlers) + +-- |Programmatically press a button to trigger its event handlers. +pressButton :: (MonadIO m) => Button -> m () +pressButton b = fireEvent b (return . buttonPressedHandlers) b + +-- |Set the text label on a button. +setButtonText :: (MonadIO m) => Button -> String -> m () +setButtonText b s = setText (buttonText b) s + +instance HasNormalAttr Button where + setNormalAttribute b a = setNormalAttribute (buttonWidget b) a + +instance HasFocusAttr Button where + setFocusAttribute b a = setFocusAttribute (buttonWidget b) a + +-- |Create a button. Get its underlying widget with 'buttonWidget'. +newButton :: (MonadIO m) => String -> m Button +newButton msg = do + t <- plainText msg + + w <- return t >>= + withPadding (padLeftRight 3) >>= + withNormalAttribute (white `on` black) >>= + withFocusAttribute (blue `on` white) + + hs <- newHandlers + + let b = Button w t hs + + w `onKeyPressed` \_ k _ -> + do + case k of + KEnter -> pressButton b + _ -> return () + return False + + return b diff --git a/src/Graphics/Vty/Widgets/Centering.hs b/src/Graphics/Vty/Widgets/Centering.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Centering.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- |This module provides widgets to center other widgets horizontally +-- and vertically. These centering widgets relay focus and key events +-- to their children. +module Graphics.Vty.Widgets.Centering + ( HCentered + , VCentered + , hCentered + , vCentered + , centered + ) +where + +import GHC.Word ( Word ) +import Control.Monad.Trans +import Graphics.Vty.Widgets.Core +import Graphics.Vty +import Graphics.Vty.Widgets.Util + +data HCentered a = (Show a) => HCentered (Widget a) + +instance Show (HCentered a) where + show (HCentered _) = "HCentered { ... }" + +-- |Wrap another widget to center it horizontally. +hCentered :: (MonadIO m, Show a) => Widget a -> m (Widget (HCentered a)) +hCentered ch = do + wRef <- newWidget $ \w -> + w { state = HCentered ch + , growHorizontal_ = const $ return True + + , growVertical_ = \(HCentered child) -> growVertical child + + , render_ = \this s ctx -> do + HCentered child <- getState this + img <- render child s ctx + + let attr' = getNormalAttr ctx + (half, half') = centered_halves region_width s (image_width img) + + return $ if half > 0 + then horiz_cat [ char_fill attr' ' ' half (image_height img) + , img + , char_fill attr' ' ' half' (image_height img) + ] + else img + + , setCurrentPosition_ = + \this pos -> do + HCentered child <- getState this + s <- getCurrentSize this + chSz <- getCurrentSize child + let (half, _) = centered_halves region_width s (region_width chSz) + chPos = pos `plusWidth` half + setCurrentPosition child chPos + } + wRef `relayKeyEvents` ch + wRef `relayFocusEvents` ch + return wRef + +data VCentered a = (Show a) => VCentered (Widget a) + +instance Show (VCentered a) where + show (VCentered _) = "VCentered { ... }" + +-- |Wrap another widget to center it vertically. +vCentered :: (MonadIO m, Show a) => Widget a -> m (Widget (VCentered a)) +vCentered ch = do + wRef <- newWidget $ \w -> + w { state = VCentered ch + , growVertical_ = const $ return True + , growHorizontal_ = const $ growHorizontal ch + + , render_ = \this s ctx -> do + VCentered child <- getState this + img <- render child s ctx + + let attr' = getNormalAttr ctx + (half, half') = centered_halves region_height s (image_height img) + + return $ if half > 0 + then vert_cat [ char_fill attr' ' ' (image_width img) half + , img + , char_fill attr' ' ' (image_width img) half' + ] + else img + + , setCurrentPosition_ = + \this pos -> do + VCentered child <- getState this + s <- getCurrentSize this + chSz <- getCurrentSize child + let (half, _) = centered_halves region_height s (region_height chSz) + chPos = pos `plusHeight` half + setCurrentPosition child chPos + } + wRef `relayKeyEvents` ch + wRef `relayFocusEvents` ch + return wRef + +-- |Wrap another widget to center it both vertically and horizontally. +centered :: (MonadIO m, Show a) => Widget a -> m (Widget (VCentered (HCentered a))) +centered wRef = vCentered =<< hCentered wRef + +centered_halves :: (DisplayRegion -> Word) -> DisplayRegion -> Word -> (Word, Word) +centered_halves region_size s obj_sz = + let remaining = region_size s - obj_sz + half = remaining `div` 2 + half' = if remaining `mod` 2 == 0 + then half + else half + 1 + in (half, half') diff --git a/src/Graphics/Vty/Widgets/CheckBox.hs b/src/Graphics/Vty/Widgets/CheckBox.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/CheckBox.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-} +-- |This module provides ''check box'' widgets and ''radio button'' +-- widgets. In addition, this module provides a generalized +-- ''multi-state'' check box type which allows you to set multiple +-- states in the checkbox, each with its own character +-- representation. +-- +-- All of these types of widgets are toggled with the Spacebar and +-- Enter keys. +module Graphics.Vty.Widgets.CheckBox + ( CheckBox + , RadioGroup + + -- * Traditional binary-mode checkboxes + , newCheckbox + , setCheckboxUnchecked + , setCheckboxChecked + , toggleCheckbox + + -- * Event handler registration + , onCheckboxChange + + -- * Generalized checkbox functions + , newMultiStateCheckbox + , setCheckboxState + , cycleCheckbox + , setStateChar + , setBracketChars + , getCheckboxLabel + , getCheckboxState + + -- * Radio groups + , newRadioGroup + , onRadioChange + , addToRadioGroup + , getCurrentRadio + ) +where + +import Data.IORef +import Data.List ( findIndex ) +import Data.Maybe +import Control.Monad +import Control.Monad.Trans +import Control.Exception +import Data.Typeable +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Events +import Graphics.Vty.Widgets.Util + +data RadioGroupData = RadioGroupData { currentlySelected :: Maybe (Widget (CheckBox Bool)) + , changeHandlers :: Handlers (Widget (CheckBox Bool)) + } + +type RadioGroup = IORef RadioGroupData + +-- |Create a new radio button group. This is used to guarantee +-- exclusivity among the check boxes in the group so that they behave +-- like radio buttons. +newRadioGroup :: (MonadIO m) => m RadioGroup +newRadioGroup = do + hs <- newHandlers + liftIO $ newIORef $ RadioGroupData Nothing hs + +-- |Register a handler to be notified when the currently-selected +-- check box in a radio group changes. +onRadioChange :: (MonadIO m) => RadioGroup -> (Widget (CheckBox Bool) -> IO ()) + -> m () +onRadioChange rg act = do + rd <- liftIO $ readIORef rg + addHandler (return . changeHandlers) rd act + +-- |Get the currently-selected checkbox in a radio group, if any. +getCurrentRadio :: (MonadIO m) => RadioGroup -> m (Maybe (Widget (CheckBox Bool))) +getCurrentRadio = (currentlySelected <~) + +-- |Add a check box to a radio group. The check box's apperance will +-- be changed so that it resembles a radio button. +addToRadioGroup :: (MonadIO m) => RadioGroup -> Widget (CheckBox Bool) -> m () +addToRadioGroup rg wRef = do + setStateChar wRef True '*' + setBracketChars wRef '(' ')' + setCheckboxUnchecked wRef + + wRef `onCheckboxChange` \v -> + when v $ do + rd <- readIORef rg + fireEvent rd (return . changeHandlers) wRef + + wRef `onCheckboxChange` \v -> + when v $ do + -- Uncheck the old currently-selected checkbox in the radio + -- group, if any, before updating the radiogroup state. + + rgData <- liftIO $ readIORef rg + + -- If the radio group has a currently-selected checkbox, + -- uncheck it (but only if it's a different widget: it could + -- be the only one in this group!) + when ((isJust $ currentlySelected rgData) && + (currentlySelected rgData /= Just wRef)) $ do + let cur = fromJust $ currentlySelected rgData + thaw cur + setChecked_ cur False + + freeze wRef + + writeIORef rg $ rgData { currentlySelected = Just wRef } + +data CheckBoxError = EmptyCheckboxStates + -- ^Indicates that an empty state list was used to + -- create a multi-state checkbox. + | BadCheckboxState + -- ^Indicates that a checkbox state value is not a + -- valid state value in the checkbox's state + -- mapping. + | BadStateArgument + -- ^Indicates that a state argument used for a + -- checkbox state transition is not a valid state + -- for the checkbox. + deriving (Show, Typeable) + +instance Exception CheckBoxError + +data CheckBox a = CheckBox { leftBracketChar :: Char + , rightBracketChar :: Char + , checkboxStates :: [(a, Char)] + , currentState :: a + , checkboxLabel :: String + , checkboxChangeHandlers :: Handlers a + , checkboxFrozen :: Bool + } + +instance Show a => Show (CheckBox a) where + show cb = concat [ "CheckBox { " + , " checkboxLabel = ", show $ checkboxLabel cb + , ", checkboxStates = ", show $ checkboxStates cb + , ", currentState = ", show $ currentState cb + , ", checkboxFrozen = ", show $ checkboxFrozen cb + , " }" + ] + +-- |Create a new checkbox with the specified text label. +newCheckbox :: (MonadIO m) => String -> m (Widget (CheckBox Bool)) +newCheckbox label = newMultiStateCheckbox label [(False, ' '), (True, 'x')] + +-- |Create a new multi-state checkbox. +newMultiStateCheckbox :: (Eq a, MonadIO m) => + String -- ^The checkbox label. + -> [(a, Char)] -- ^The list of valid states that + -- the checkbox can be in, along + -- with the visual representation + -- ('Char') for each state. + -> m (Widget (CheckBox a)) +newMultiStateCheckbox _ [] = throw EmptyCheckboxStates +newMultiStateCheckbox label states = do + cchs <- newHandlers + wRef <- newWidget $ \w -> + w { state = CheckBox { checkboxLabel = label + , checkboxChangeHandlers = cchs + , leftBracketChar = '[' + , rightBracketChar = ']' + , checkboxStates = states + , currentState = fst $ states !! 0 + , checkboxFrozen = False + } + , getCursorPosition_ = + \this -> do + pos <- getCurrentPosition this + return $ Just (pos `plusWidth` 1) + + , keyEventHandler = radioKeyEvent + , render_ = + \this sz ctx -> do + f <- focused <~ this + st <- getState this + + let attr = mergeAttrs [ overrideAttr ctx + , normalAttr ctx + ] + + fAttr = if f + then focusAttr ctx + else attr + + v = currentState st + ch = fromJust $ lookup v (checkboxStates st) + + s = [leftBracketChar st, ch, rightBracketChar st, ' '] ++ + (checkboxLabel st) + + return $ string fAttr $ take (fromEnum $ region_width sz) s + } + return wRef + +modifyElem :: [a] -> Int -> (a -> a) -> [a] +modifyElem as i f = concat [ take i as + , [f $ as !! i] + , drop (i + 1) as + ] + +-- |Set the visual representation for a state in a checkbox. May +-- throw 'BadStateArgument'. +setStateChar :: (Eq a, MonadIO m) => Widget (CheckBox a) -> a -> Char -> m () +setStateChar wRef v ch = do + states <- checkboxStates <~~ wRef + + let mIdx = findIndex ((== v) . fst) states + when (isNothing mIdx) $ throw BadStateArgument + + let Just i = mIdx + newStates = modifyElem states i (\(k, _) -> (k, ch)) + + updateWidgetState wRef $ \s -> s { checkboxStates = newStates } + +-- |Set the checkbox's bracketing characters for the left and right +-- brackets around the state character. +setBracketChars :: (MonadIO m) => Widget (CheckBox a) -> Char -> Char -> m () +setBracketChars wRef chL chR = + updateWidgetState wRef $ \s -> s { leftBracketChar = chL + , rightBracketChar = chR + } + +-- |Get a checkbox's text label. +getCheckboxLabel :: (MonadIO m) => Widget (CheckBox a) -> m String +getCheckboxLabel = (checkboxLabel <~~) + +radioKeyEvent :: (Eq a) => Widget (CheckBox a) -> Key -> [Modifier] -> IO Bool +radioKeyEvent this (KASCII ' ') [] = cycleCheckbox this >> return True +radioKeyEvent this KEnter [] = cycleCheckbox this >> return True +radioKeyEvent _ _ _ = return False + +-- |Set the state of a checkbox. May throw 'BadCheckboxState'. +setCheckboxState :: (Eq a, MonadIO m) => Widget (CheckBox a) -> a -> m () +setCheckboxState = setChecked_ + +-- |Set a binary checkbox to unchecked. +setCheckboxUnchecked :: (MonadIO m) => Widget (CheckBox Bool) -> m () +setCheckboxUnchecked wRef = setCheckboxState wRef False + +-- |Set a binary checkbox to checked. +setCheckboxChecked :: (MonadIO m) => Widget (CheckBox Bool) -> m () +setCheckboxChecked wRef = setCheckboxState wRef True + +-- |Toggle a binary checkbox. +toggleCheckbox :: (MonadIO m) => Widget (CheckBox Bool) -> m () +toggleCheckbox wRef = do + v <- currentState <~~ wRef + setCheckboxState wRef (not v) + +-- |Get a checkbox's current state value. +getCheckboxState :: (MonadIO m) => Widget (CheckBox a) -> m a +getCheckboxState = (currentState <~~) + +-- |Cycle a checkbox's state to the next value in its state list. +cycleCheckbox :: (Eq a, MonadIO m) => Widget (CheckBox a) -> m () +cycleCheckbox wRef = do + v <- currentState <~~ wRef + states <- checkboxStates <~~ wRef + let Just curI = findIndex ((== v) . fst) states + nextI = (curI + 1) `mod` length states + setChecked_ wRef $ fst $ states !! nextI + +setChecked_ :: (Eq a, MonadIO m) => Widget (CheckBox a) -> a -> m () +setChecked_ wRef v = do + f <- checkboxFrozen <~~ wRef + + when (not f) $ do + oldV <- currentState <~~ wRef + states <- checkboxStates <~~ wRef + + when (not $ v `elem` (map fst states)) $ + throw BadCheckboxState + + when (oldV /= v) $ + do + updateWidgetState wRef $ \s -> s { currentState = v } + notifyChangeHandlers wRef + +notifyChangeHandlers :: (MonadIO m) => Widget (CheckBox a) -> m () +notifyChangeHandlers wRef = do + v <- currentState <~~ wRef + fireEvent wRef (checkboxChangeHandlers <~~) v + +-- |Register a handler for a checkbox state change. The handler will +-- be passed the new state value. +onCheckboxChange :: (MonadIO m) => Widget (CheckBox a) -> (a -> IO ()) -> m () +onCheckboxChange = addHandler (checkboxChangeHandlers <~~) + +thaw :: (MonadIO m) => Widget (CheckBox a) -> m () +thaw wRef = updateWidgetState wRef $ \s -> s { checkboxFrozen = False } + +freeze :: (MonadIO m) => Widget (CheckBox a) -> m () +freeze wRef = updateWidgetState wRef $ \s -> s { checkboxFrozen = True } diff --git a/src/Graphics/Vty/Widgets/Composed.hs b/src/Graphics/Vty/Widgets/Composed.hs deleted file mode 100644 --- a/src/Graphics/Vty/Widgets/Composed.hs +++ /dev/null @@ -1,32 +0,0 @@ --- |This module provides high-level composed widgets. -module Graphics.Vty.Widgets.Composed - ( bottomPadded - , topPadded - , boxLimit - ) -where - -import Graphics.Vty.Widgets.Rendering - ( Widget(primaryAttribute) - ) -import Graphics.Vty.Widgets.Base - ( (<-->) - , vFill - , vLimit - , hLimit - ) - --- |Add expanding bottom padding to a widget. -bottomPadded :: Widget -> Widget -bottomPadded w = w <--> vFill (primaryAttribute w) ' ' - --- |Add expanding top padding to a widget. -topPadded :: Widget -> Widget -topPadded w = vFill (primaryAttribute w) ' ' <--> w - --- |Impose a maximum size (width, height) on a widget. -boxLimit :: Int -- ^Maximum width in columns - -> Int -- ^Maximum height in rows - -> Widget - -> Widget -boxLimit maxWidth maxHeight = vLimit maxHeight . hLimit maxWidth diff --git a/src/Graphics/Vty/Widgets/Core.hs b/src/Graphics/Vty/Widgets/Core.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Core.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, TypeSynonymInstances #-} +-- |This module is the core of this library; it provides +-- infrastructure for creating new types of widgets and extending +-- their functionality. This module provides various bits of +-- infrastructure, including: +-- +-- * modeling user interface widgets +-- +-- * managing changes in focus between widgets +-- +-- * managing widget state +-- +-- This module does not provide any concrete widget types. For +-- in-depth discussion on this module's API and widget implementation +-- in particular, see the Vty-ui User's Manual. +module Graphics.Vty.Widgets.Core + ( + -- ** Widget Infrastructure + WidgetImpl(..) + , Widget + , getNormalAttr + , defaultContext + , updateWidget + , updateWidgetState + , newWidget + , getState + , getCurrentSize + , setCurrentPosition + , getCurrentPosition + , growVertical + , growHorizontal + , getCursorPosition + , showWidget + , (<~) + , (<~~) + + -- ** Rendering + , RenderContext(..) + , RenderError(..) + , render + , renderAndPosition + + -- ** Miscellaneous + , HasNormalAttr(..) + , HasFocusAttr(..) + , withNormalAttribute + , withFocusAttribute + + -- ** Events + , handleKeyEvent + , onKeyPressed + , onGainFocus + , onLoseFocus + , relayKeyEvents + , relayFocusEvents + + -- ** Focus management + , FocusGroup + , FocusGroupError(..) + , newFocusGroup + , mergeFocusGroups + , resetFocusGroup + , addToFocusGroup + , focusNext + , focusPrevious + , setFocusGroupNextKey + , setFocusGroupPrevKey + , focus + , unfocus + ) +where + +import Data.Typeable +import Data.IORef +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Exception +import Graphics.Vty +import Graphics.Vty.Widgets.Util +import Graphics.Vty.Widgets.Skins +import Graphics.Vty.Widgets.Events + +class HasNormalAttr w where + setNormalAttribute :: (MonadIO m) => w -> Attr -> m () + +class HasFocusAttr w where + setFocusAttribute :: (MonadIO m) => w -> Attr -> m () + +instance HasNormalAttr (Widget a) where + setNormalAttribute wRef a = + updateWidget wRef $ \w -> w { normalAttribute = mergeAttr a (normalAttribute w) } + +instance HasFocusAttr (Widget a) where + setFocusAttribute wRef a = + updateWidget wRef $ \w -> w { focusAttribute = mergeAttr a (focusAttribute w) } + +withNormalAttribute :: (HasNormalAttr w, MonadIO m) => Attr -> w -> m w +withNormalAttribute att w = do + setNormalAttribute w att + return w + +withFocusAttribute :: (HasFocusAttr w, MonadIO m) => Attr -> w -> m w +withFocusAttribute att w = do + setFocusAttribute w att + return w + +data RenderError = ImageTooBig String DisplayRegion DisplayRegion + deriving (Show, Typeable) + +instance Exception RenderError + +data RenderContext = RenderContext { normalAttr :: Attr + , focusAttr :: Attr + , overrideAttr :: Attr + , skin :: Skin + } + +getNormalAttr :: RenderContext -> Attr +getNormalAttr ctx = mergeAttrs [ overrideAttr ctx, normalAttr ctx ] + +defaultContext :: RenderContext +defaultContext = RenderContext def_attr def_attr def_attr unicodeSkin + +data WidgetImpl a = WidgetImpl { + state :: a + , render_ :: Widget a -> DisplayRegion -> RenderContext -> IO Image + , growHorizontal_ :: a -> IO Bool + , growVertical_ :: a -> IO Bool + , currentSize :: DisplayRegion + , currentPosition :: DisplayRegion + , normalAttribute :: Attr + , focusAttribute :: Attr + , setCurrentPosition_ :: Widget a -> DisplayRegion -> IO () + , keyEventHandler :: Widget a -> Key -> [Modifier] -> IO Bool + , gainFocusHandlers :: Handlers (Widget a) + , loseFocusHandlers :: Handlers (Widget a) + , focused :: Bool + , getCursorPosition_ :: Widget a -> IO (Maybe DisplayRegion) + } + +type Widget a = IORef (WidgetImpl a) + +showWidget :: (Functor m, MonadIO m, Show a) => Widget a -> m String +showWidget wRef = show <$> (liftIO $ readIORef wRef) + +instance (Show a) => Show (WidgetImpl a) where + show w = concat [ "WidgetImpl { " + , show $ state w + , ", currentSize = " + , show $ currentSize w + , ", currentPosition = " + , show $ currentPosition w + , ", focused = " + , show $ focused w + , " }" + ] + +growHorizontal :: (MonadIO m) => Widget a -> m Bool +growHorizontal w = do + act <- growHorizontal_ <~ w + st <- state <~ w + liftIO $ act st + +growVertical :: (MonadIO m) => Widget a -> m Bool +growVertical w = do + act <- growVertical_ <~ w + st <- state <~ w + liftIO $ act st + +render :: (MonadIO m, Show a) => Widget a -> DisplayRegion -> RenderContext -> m Image +render wRef sz ctx = + liftIO $ do + impl <- readIORef wRef + + -- Merge the override attributes with the context. If the + -- overrides haven't been set (still def_attr), they will have + -- no effect on the context attributes. + norm <- normalAttribute <~ wRef + foc <- focusAttribute <~ wRef + let newCtx = ctx { normalAttr = mergeAttr norm $ normalAttr ctx + , focusAttr = mergeAttr foc $ focusAttr ctx + } + + img <- render_ impl wRef sz newCtx + let imgsz = DisplayRegion (image_width img) (image_height img) + when (image_width img > region_width sz || + image_height img > region_height sz) $ throw $ ImageTooBig (show impl) sz imgsz + setCurrentSize wRef $ DisplayRegion (image_width img) (image_height img) + return img + +renderAndPosition :: (MonadIO m, Show a) => Widget a -> DisplayRegion -> DisplayRegion + -> RenderContext -> m Image +renderAndPosition wRef pos sz ctx = do + img <- render wRef sz ctx + -- Position post-processing depends on the sizes being correct! + setCurrentPosition wRef pos + return img + +setCurrentSize :: (MonadIO m) => Widget a -> DisplayRegion -> m () +setCurrentSize wRef newSize = + liftIO $ modifyIORef wRef $ \w -> w { currentSize = newSize } + +getCurrentSize :: (MonadIO m) => Widget a -> m DisplayRegion +getCurrentSize wRef = (return . currentSize) =<< (liftIO $ readIORef wRef) + +getCurrentPosition :: (MonadIO m, Functor m) => Widget a -> m DisplayRegion +getCurrentPosition wRef = currentPosition <$> (liftIO $ readIORef wRef) + +setCurrentPosition :: (MonadIO m) => Widget a -> DisplayRegion -> m () +setCurrentPosition wRef pos = do + updateWidget wRef $ \w -> w { currentPosition = pos } + liftIO $ do + w <- readIORef wRef + (setCurrentPosition_ w) wRef pos + +newWidget :: (MonadIO m) => (WidgetImpl a -> WidgetImpl a) -> m (Widget a) +newWidget f = do + gfhs <- newHandlers + lfhs <- newHandlers + + wRef <- liftIO $ newIORef $ + WidgetImpl { state = undefined + , render_ = undefined + , growVertical_ = const $ return False + , growHorizontal_ = const $ return False + , setCurrentPosition_ = \_ _ -> return () + , currentSize = DisplayRegion 0 0 + , currentPosition = DisplayRegion 0 0 + , focused = False + , gainFocusHandlers = gfhs + , loseFocusHandlers = lfhs + , keyEventHandler = \_ _ _ -> return False + , getCursorPosition_ = defaultCursorInfo + , normalAttribute = def_attr + , focusAttribute = def_attr + } + + updateWidget wRef f + return wRef + +defaultCursorInfo :: Widget a -> IO (Maybe DisplayRegion) +defaultCursorInfo w = do + sz <- getCurrentSize w + pos <- getCurrentPosition w + return $ Just $ pos `plusWidth` (region_width sz - 1) + +handleKeyEvent :: (MonadIO m) => Widget a -> Key -> [Modifier] -> m Bool +handleKeyEvent wRef keyEvent mods = do + act <- keyEventHandler <~ wRef + liftIO $ act wRef keyEvent mods + +relayKeyEvents :: (MonadIO m) => Widget a -> Widget b -> m () +relayKeyEvents a b = a `onKeyPressed` \_ k mods -> handleKeyEvent b k mods + +relayFocusEvents :: (MonadIO m) => Widget a -> Widget b -> m () +relayFocusEvents a b = do + a `onGainFocus` \_ -> focus b + a `onLoseFocus` \_ -> unfocus b + +onKeyPressed :: (MonadIO m) => Widget a -> (Widget a -> Key -> [Modifier] -> IO Bool) -> m () +onKeyPressed wRef handler = do + -- Create a new handler that calls this one but defers to the old + -- one if the new one doesn't handle the event. + oldHandler <- keyEventHandler <~ wRef + + let combinedHandler = + \w k ms -> do + v <- handler w k ms + case v of + True -> return True + False -> oldHandler w k ms + + updateWidget wRef $ \w -> w { keyEventHandler = combinedHandler } + +focus :: (MonadIO m) => Widget a -> m () +focus wRef = do + updateWidget wRef $ \w -> w { focused = True } + fireEvent wRef (gainFocusHandlers <~) wRef + +unfocus :: (MonadIO m) => Widget a -> m () +unfocus wRef = do + updateWidget wRef $ \w -> w { focused = False } + fireEvent wRef (loseFocusHandlers <~) wRef + +onGainFocus :: (MonadIO m) => Widget a -> (Widget a -> IO ()) -> m () +onGainFocus = addHandler (gainFocusHandlers <~) + +onLoseFocus :: (MonadIO m) => Widget a -> (Widget a -> IO ()) -> m () +onLoseFocus = addHandler (loseFocusHandlers <~) + +(<~) :: (MonadIO m) => (a -> b) -> IORef a -> m b +(<~) f wRef = (return . f) =<< (liftIO $ readIORef wRef) + +(<~~) :: (MonadIO m) => (a -> b) -> Widget a -> m b +(<~~) f wRef = (return . f . state) =<< (liftIO $ readIORef wRef) + +updateWidget :: (MonadIO m) => Widget a -> (WidgetImpl a -> WidgetImpl a) -> m () +updateWidget wRef f = (liftIO $ modifyIORef wRef f) + +getState :: (MonadIO m) => Widget a -> m a +getState wRef = state <~ wRef + +updateWidgetState :: (MonadIO m) => Widget a -> (a -> a) -> m () +updateWidgetState wRef f = + liftIO $ do + w <- readIORef wRef + writeIORef wRef $ w { state = f (state w) } + +data FocusGroupError = FocusGroupEmpty + | FocusGroupBadIndex Int + deriving (Typeable, Show) + +instance Exception FocusGroupError + +data FocusEntry = forall a. FocusEntry (Widget a) + +data FocusGroup = FocusGroup { entries :: [Widget FocusEntry] + , currentEntryNum :: Int + , nextKey :: (Key, [Modifier]) + , prevKey :: (Key, [Modifier]) + } + +newFocusEntry :: (MonadIO m, Show a) => Widget a -> m (Widget FocusEntry) +newFocusEntry chRef = do + wRef <- newWidget $ \w -> + w { state = FocusEntry chRef + + , growHorizontal_ = const $ growHorizontal chRef + , growVertical_ = const $ growVertical chRef + + , render_ = + \_ sz ctx -> render chRef sz ctx + + , setCurrentPosition_ = + \this pos -> do + (FocusEntry ch) <- getState this + setCurrentPosition ch pos + } + + wRef `relayFocusEvents` chRef + wRef `relayKeyEvents` chRef + + return wRef + +newFocusGroup :: (MonadIO m) => m (Widget FocusGroup) +newFocusGroup = do + wRef <- newWidget $ \w -> + w { state = FocusGroup { entries = [] + , currentEntryNum = -1 + , nextKey = (KASCII '\t', []) + , prevKey = (KASCII '\t', [MShift]) + } + + , getCursorPosition_ = + \this -> do + eRef <- currentEntry this + (FocusEntry e) <- state <~ eRef + getCursorPosition e + + , keyEventHandler = + \this key mods -> do + st <- getState this + case currentEntryNum st of + (-1) -> return False + i -> do + if (key, mods) == nextKey st then + (focusNext this >> return True) else + if (key, mods) == prevKey st then + (focusPrevious this >> return True) else + do + let e = entries st !! i + handleKeyEvent e key mods + + -- Should never be rendered. + , render_ = \_ _ _ -> return empty_image + } + return wRef + +setFocusGroupNextKey :: (MonadIO m) => Widget FocusGroup -> Key -> [Modifier] -> m () +setFocusGroupNextKey fg k mods = + updateWidgetState fg $ \s -> s { nextKey = (k, mods) } + +setFocusGroupPrevKey :: (MonadIO m) => Widget FocusGroup -> Key -> [Modifier] -> m () +setFocusGroupPrevKey fg k mods = + updateWidgetState fg $ \s -> s { prevKey = (k, mods) } + +mergeFocusGroups :: (MonadIO m) => Widget FocusGroup -> Widget FocusGroup -> m (Widget FocusGroup) +mergeFocusGroups a b = do + c <- newFocusGroup + + aEntries <- entries <~~ a + bEntries <- entries <~~ b + + when (null aEntries || null bEntries) $ + throw FocusGroupEmpty + + updateWidgetState c $ \s -> s { entries = aEntries ++ bEntries + , currentEntryNum = 0 + } + + return c + +resetFocusGroup :: (MonadIO m) => Widget FocusGroup -> m () +resetFocusGroup fg = do + cur <- currentEntryNum <~~ fg + es <- entries <~~ fg + forM_ (zip [1..] es) $ \(i, e) -> + when (i /= cur) $ unfocus e + when (cur >= 0) $ + focus =<< currentEntry fg + +getCursorPosition :: (MonadIO m) => Widget a -> m (Maybe DisplayRegion) +getCursorPosition wRef = do + ci <- getCursorPosition_ <~ wRef + liftIO (ci wRef) + +currentEntry :: (MonadIO m) => Widget FocusGroup -> m (Widget FocusEntry) +currentEntry wRef = do + es <- entries <~~ wRef + i <- currentEntryNum <~~ wRef + when (i == -1) $ throw FocusGroupEmpty + return (es !! i) + +addToFocusGroup :: (MonadIO m, Show a) => Widget FocusGroup -> Widget a -> m (Widget FocusEntry) +addToFocusGroup cRef wRef = do + eRef <- newFocusEntry wRef + + entryPos <- (length . entries) <~~ cRef + updateWidgetState cRef $ \s -> s { entries = (entries s) ++ [eRef] } + + -- Add an event handler to the widget, NOT the entry wrapper, so + -- others can call 'focus' on the widget and affect this focus + -- group. + wRef `onGainFocus` \_ -> + setCurrentFocus cRef entryPos + + -- If we just added the first widget to the group, focus it so + -- something has focus. + when (entryPos == 0) $ focus eRef + + return eRef + +focusNext :: (MonadIO m) => Widget FocusGroup -> m () +focusNext wRef = do + st <- getState wRef + let cur = currentEntryNum st + when (cur == -1) $ throw FocusGroupEmpty + let nextEntry = if cur < length (entries st) - 1 then + (entries st) !! (cur + 1) else + (entries st) !! 0 + focus nextEntry + +focusPrevious :: (MonadIO m) => Widget FocusGroup -> m () +focusPrevious wRef = do + st <- getState wRef + let cur = currentEntryNum st + when (cur == -1) $ throw FocusGroupEmpty + let prevEntry = if cur > 0 then + (entries st) !! (cur - 1) else + (entries st) !! (length (entries st) - 1) + focus prevEntry + +-- Note that this only 1) updates the focus index in the group and 2) +-- calls unfocus on the previously-focused widget. This does NOT call +-- focus on the newly-focused widget, because this is intended to be +-- callable from a focus event handler for the widget that got +-- focused. +setCurrentFocus :: (MonadIO m) => Widget FocusGroup -> Int -> m () +setCurrentFocus cRef i = do + st <- state <~ cRef + + when (i >= length (entries st) || i < 0) $ + throw $ FocusGroupBadIndex i + + -- If new entry number is different from existing one, invoke focus + -- handlers. + when (currentEntryNum st /= i) $ + do + when (currentEntryNum st >= 0) $ + unfocus ((entries st) !! (currentEntryNum st)) + + updateWidgetState cRef $ \s -> s { currentEntryNum = i } diff --git a/src/Graphics/Vty/Widgets/Dialog.hs b/src/Graphics/Vty/Widgets/Dialog.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Dialog.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +-- |This module provides a simple ''dialog'' interface with an ''OK'' +-- button and a ''Cancel'' button. The dialog itself is capable of +-- embedding an arbitrary interface and it exposes ''accept'' and +-- ''cancel'' events which are triggered by the dialog's buttons. +module Graphics.Vty.Widgets.Dialog + ( Dialog(dialogWidget, setDialogTitle) + , newDialog + , onDialogAccept + , onDialogCancel + , acceptDialog + , cancelDialog + ) +where + +import Control.Monad.Trans +import Graphics.Vty.Widgets.Centering +import Graphics.Vty.Widgets.Button +import Graphics.Vty.Widgets.Padding +import Graphics.Vty.Widgets.Events +import Graphics.Vty.Widgets.Borders +import Graphics.Vty.Widgets.Box +import Graphics.Vty.Widgets.Core + +data Dialog = Dialog { dialogWidget :: Widget (Bordered Padded) + , setDialogTitle :: String -> IO () + , dialogAcceptHandlers :: Handlers Dialog + , dialogCancelHandlers :: Handlers Dialog + } + +instance HasNormalAttr Dialog where + setNormalAttribute d a = setNormalAttribute (dialogWidget d) a + +-- |Create a new dialog with the specified embedded interface and +-- title. Returns the dialog itself and the 'FocusGroup' to which its +-- buttons were added, for use in your application. +newDialog :: (MonadIO m, Show a) => Widget a -> String -> m (Dialog, Widget FocusGroup) +newDialog body title = do + okB <- newButton "OK" + cancelB <- newButton "Cancel" + + buttonBox <- (return $ buttonWidget okB) <++> (return $ buttonWidget cancelB) + setBoxSpacing buttonBox 4 + + b <- withPadding (padTopBottom 1) =<< + ((hCentered body) <--> (hCentered buttonBox) >>= withBoxSpacing 1) + + fg <- newFocusGroup + addToFocusGroup fg $ buttonWidget okB + addToFocusGroup fg $ buttonWidget cancelB + + b2 <- bordered b >>= + withBorderedLabel title + + ahs <- newHandlers + chs <- newHandlers + + let dlg = Dialog { dialogWidget = b2 + , setDialogTitle = setBorderedLabel b2 + , dialogAcceptHandlers = ahs + , dialogCancelHandlers = chs + } + + okB `onButtonPressed` (const $ acceptDialog dlg) + cancelB `onButtonPressed` (const $ cancelDialog dlg) + + return (dlg, fg) + +-- |Register an event handler for the dialog's acceptance event. +onDialogAccept :: (MonadIO m) => Dialog -> (Dialog -> IO ()) -> m () +onDialogAccept = addHandler (return . dialogAcceptHandlers) + +-- |Register an event handler for the dialog's cancellation event. +onDialogCancel :: (MonadIO m) => Dialog -> (Dialog -> IO ()) -> m () +onDialogCancel = addHandler (return . dialogCancelHandlers) + +-- |Programmatically accept the dialog. +acceptDialog :: (MonadIO m) => Dialog -> m () +acceptDialog dlg = fireEvent dlg (return . dialogAcceptHandlers) dlg + +-- |Programmatically cancel the dialog. +cancelDialog :: (MonadIO m) => Dialog -> m () +cancelDialog dlg = fireEvent dlg (return . dialogCancelHandlers) dlg diff --git a/src/Graphics/Vty/Widgets/DirBrowser.hs b/src/Graphics/Vty/Widgets/DirBrowser.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/DirBrowser.hs @@ -0,0 +1,337 @@ +-- |This module provides a directory browser interface widget. For +-- full details, please see the Vty-ui User's Manual. +module Graphics.Vty.Widgets.DirBrowser + ( DirBrowser(dirBrowserWidget) + , BrowserSkin(..) + , newDirBrowser + , withAnnotations + , setDirBrowserPath + , getDirBrowserPath + , defaultBrowserSkin + , onBrowseAccept + , onBrowseCancel + , onBrowserPathChange + , reportBrowserError + , refreshBrowser + ) +where + +import Data.IORef +import qualified Data.Map as Map +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.List +import Graphics.Vty.Widgets.Text +import Graphics.Vty.Widgets.Box +import Graphics.Vty.Widgets.Fills +import Graphics.Vty.Widgets.Util +import Graphics.Vty.Widgets.Events +import System.Directory +import System.FilePath +import System.Posix.Files +import System.IO.Error + +type T = Widget (Box + (Box (Box FormattedText FormattedText) HFill) + (Box + (List [Char] (Box FormattedText FormattedText)) + (Box + (Box (Box FormattedText FormattedText) HFill) + FormattedText))) + +data DirBrowser = DirBrowser { dirBrowserWidget :: T + , dirBrowserList :: Widget (List String (Box FormattedText FormattedText)) + , dirBrowserPath :: IORef FilePath + , dirBrowserPathDisplay :: Widget FormattedText + , dirBrowserSelectionMap :: IORef (Map.Map FilePath Int) + , dirBrowserFileInfo :: Widget FormattedText + , dirBrowserSkin :: BrowserSkin + , dirBrowserErrorWidget :: Widget FormattedText + , dirBrowserChooseHandlers :: Handlers FilePath + , dirBrowserCancelHandlers :: Handlers FilePath + , dirBrowserPathChangeHandlers :: Handlers FilePath + } + +-- |The collection of attributes and annotations used to determine the +-- browser's visual appearance. +data BrowserSkin = BrowserSkin { browserHeaderAttr :: Attr + -- ^Used for the header and footer + -- areas of the interface. + , browserUnfocusedSelAttr :: Attr + -- ^Used for the selected entry when + -- the browser does not have focus. + , browserErrorAttr :: Attr + -- ^Used for the browser's + -- error-reporting area. + , browserDirAttr :: Attr + -- ^Used for directory entries. + , browserLinkAttr :: Attr + -- ^Used for symbolic link entries. + , browserBlockDevAttr :: Attr + -- ^Used for block device entries. + , browserNamedPipeAttr :: Attr + -- ^Used for named pipe entries. + , browserCharDevAttr :: Attr + -- ^Used for device entries. + , browserSockAttr :: Attr + -- ^Used for socket entries. + , browserCustomAnnotations :: [ (FilePath -> FileStatus -> Bool + , FilePath -> FileStatus -> IO String + , Attr) + ] + -- ^File annotations. + } + +-- |The default browser skin with (hopefully) sane attribute defaults. +defaultBrowserSkin :: BrowserSkin +defaultBrowserSkin = BrowserSkin { browserHeaderAttr = white `on` blue + , browserUnfocusedSelAttr = bgColor blue + , browserErrorAttr = white `on` red + , browserDirAttr = fgColor green + , browserLinkAttr = fgColor cyan + , browserBlockDevAttr = fgColor red + , browserNamedPipeAttr = fgColor yellow + , browserCharDevAttr = fgColor red + , browserSockAttr = fgColor magenta + , browserCustomAnnotations = [] + } + +-- |Apply annotations to a browser skin. +withAnnotations :: BrowserSkin + -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO String, Attr)] + -> BrowserSkin +withAnnotations sk as = sk { browserCustomAnnotations = browserCustomAnnotations sk ++ as } + +-- |Create a directory browser widget with the specified skin. +-- Returns the browser itself along with its focus group. +newDirBrowser :: (MonadIO m) => BrowserSkin -> m (DirBrowser, Widget FocusGroup) +newDirBrowser bSkin = do + path <- liftIO $ getCurrentDirectory + pathWidget <- plainText "" + errorText <- plainText "" >>= withNormalAttribute (browserErrorAttr bSkin) + header <- ((plainText " Path: ") <++> (return pathWidget) <++> (hFill ' ' 1)) + >>= withNormalAttribute (browserHeaderAttr bSkin) + + fileInfo <- plainText "" + footer <- ((plainText " ") <++> (return fileInfo) <++> (hFill ' ' 1) <++> (return errorText)) + >>= withNormalAttribute (browserHeaderAttr bSkin) + + l <- newList (browserUnfocusedSelAttr bSkin) (\s -> plainText " " <++> plainText s) + ui <- vBox header =<< vBox l footer + + r <- liftIO $ newIORef "" + r2 <- liftIO $ newIORef Map.empty + + hs <- newHandlers + chs <- newHandlers + pchs <- newHandlers + + let b = DirBrowser { dirBrowserWidget = ui + , dirBrowserList = l + , dirBrowserPath = r + , dirBrowserPathDisplay = pathWidget + , dirBrowserSelectionMap = r2 + , dirBrowserFileInfo = fileInfo + , dirBrowserSkin = bSkin + , dirBrowserChooseHandlers = hs + , dirBrowserCancelHandlers = chs + , dirBrowserPathChangeHandlers = pchs + , dirBrowserErrorWidget = errorText + } + + l `onKeyPressed` handleBrowserKey b + l `onSelectionChange` (\e -> clearError b >> handleSelectionChange b e) + b `onBrowserPathChange` setText (dirBrowserPathDisplay b) + + fg <- newFocusGroup + _ <- addToFocusGroup fg l + + setDirBrowserPath b path + return (b, fg) + +-- |Report an error in the browser's error-reporting area. Useful for +-- reporting application-specific errors with the user's file +-- selection. +reportBrowserError :: (MonadIO m) => DirBrowser -> String -> m () +reportBrowserError b msg = setText (dirBrowserErrorWidget b) $ "Error: " ++ msg + +clearError :: (MonadIO m) => DirBrowser -> m () +clearError b = setText (dirBrowserErrorWidget b) "" + +-- |Register handlers to be invoked when the user makes a selection. +onBrowseAccept :: (MonadIO m) => DirBrowser -> (FilePath -> IO ()) -> m () +onBrowseAccept = addHandler (return . dirBrowserChooseHandlers) + +-- |Register handlers to be invoked when the user cancels browsing. +onBrowseCancel :: (MonadIO m) => DirBrowser -> (FilePath -> IO ()) -> m () +onBrowseCancel = addHandler (return . dirBrowserCancelHandlers) + +-- |Register handlers to be invoked when the browser's path changes. +onBrowserPathChange :: (MonadIO m) => DirBrowser -> (FilePath -> IO ()) -> m () +onBrowserPathChange = addHandler (return . dirBrowserPathChangeHandlers) + +cancelBrowse :: (MonadIO m) => DirBrowser -> m () +cancelBrowse b = fireEvent b (return . dirBrowserCancelHandlers) =<< getDirBrowserPath b + +chooseCurrentEntry :: (MonadIO m) => DirBrowser -> m () +chooseCurrentEntry b = do + p <- getDirBrowserPath b + mCur <- getSelected (dirBrowserList b) + case mCur of + Nothing -> return () + Just (_, (e, _)) -> fireEvent b (return . dirBrowserChooseHandlers) (p e) + +handleSelectionChange :: DirBrowser -> SelectionEvent String b -> IO () +handleSelectionChange b ev = do + case ev of + SelectionOff -> setText (dirBrowserFileInfo b) "-" + SelectionOn _ path _ -> setText (dirBrowserFileInfo b) =<< getFileInfo b path + +getFileInfo :: (MonadIO m) => DirBrowser -> FilePath -> m String +getFileInfo b path = do + cur <- getDirBrowserPath b + let newPath = cur path + st <- liftIO $ getSymbolicLinkStatus newPath + (_, mkAnn) <- fileAnnotation (dirBrowserSkin b) st cur path + ann <- liftIO mkAnn + return $ path ++ ": " ++ ann + +builtInAnnotations :: FilePath -> BrowserSkin -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO String, Attr)] +builtInAnnotations cur sk = + [ (\_ s -> isRegularFile s + , \_ s -> return $ "regular file, " ++ + (show $ fileSize s) ++ " bytes" + , def_attr) + , (\_ s -> isSymbolicLink s, + (\p stat -> do + linkDest <- if not $ isSymbolicLink stat + then return "" + else do + linkPath <- liftIO $ readSymbolicLink p + liftIO $ canonicalizePath $ cur linkPath + return $ "symbolic link to " ++ linkDest) + , browserLinkAttr sk) + , (\_ s -> isDirectory s, \_ _ -> return "directory", browserDirAttr sk) + , (\_ s -> isBlockDevice s, \_ _ -> return "block device", browserBlockDevAttr sk) + , (\_ s -> isNamedPipe s, \_ _ -> return "named pipe", browserNamedPipeAttr sk) + , (\_ s -> isCharacterDevice s, \_ _ -> return "character device", browserCharDevAttr sk) + , (\_ s -> isSocket s, \_ _ -> return "socket", browserSockAttr sk) + ] + +fileAnnotation :: (MonadIO m) => BrowserSkin -> FileStatus -> FilePath -> FilePath -> m (Attr, IO String) +fileAnnotation sk st cur shortPath = do + let fullPath = cur shortPath + + annotation = getAnnotation' fullPath st $ (browserCustomAnnotations sk) ++ + (builtInAnnotations cur sk) + + getAnnotation' _ _ [] = (def_attr, return "") + getAnnotation' pth stat ((f,mkAnn,a):rest) = + if f pth stat + then (a, mkAnn pth stat) + else getAnnotation' pth stat rest + + return annotation + +handleBrowserKey :: DirBrowser -> Widget (List a b) -> Key -> [Modifier] -> IO Bool +handleBrowserKey b _ KEnter [] = descend b True >> return True +handleBrowserKey b _ KRight [] = descend b False >> return True +handleBrowserKey b _ KLeft [] = ascend b >> return True +handleBrowserKey b _ KEsc [] = cancelBrowse b >> return True +handleBrowserKey b _ (KASCII 'q') [] = cancelBrowse b >> return True +handleBrowserKey b _ (KASCII 'r') [] = refreshBrowser b >> return True +handleBrowserKey _ _ _ _ = return False + +-- |Refresh the browser by reloading and displaying the contents of +-- the browser's current path. +refreshBrowser :: (MonadIO m) => DirBrowser -> m () +refreshBrowser b = setDirBrowserPath b =<< getDirBrowserPath b + +-- |Set the browser's current path. +setDirBrowserPath :: (MonadIO m) => DirBrowser -> FilePath -> m () +setDirBrowserPath b path = do + cPath <- liftIO $ canonicalizePath path + + -- If for some reason we can't load the directory, report an error + -- and don't change the browser state. + (res, entries) <- + liftIO $ (do + entries <- getDirectoryContents cPath + return (True, entries)) + `catch` \e -> do + reportBrowserError b (ioeGetErrorString e) + return (False, []) + + when res $ do + -- If something is currently selected, store that in the selection + -- map before changing the path. + cur <- getDirBrowserPath b + mCur <- getSelected (dirBrowserList b) + case mCur of + Nothing -> return () + Just (i, _) -> storeSelection b cur i + + clearList (dirBrowserList b) + liftIO $ modifyIORef (dirBrowserPath b) $ const cPath + + liftIO $ load b cPath entries + + sel <- getSelection b path + case sel of + Nothing -> return () + Just i -> scrollBy (dirBrowserList b) i + + fireEvent b (return . dirBrowserPathChangeHandlers) cPath + +-- |Get the browser's current path. +getDirBrowserPath :: (MonadIO m) => DirBrowser -> m FilePath +getDirBrowserPath = liftIO . readIORef . dirBrowserPath + +storeSelection :: (MonadIO m) => DirBrowser -> FilePath -> Int -> m () +storeSelection b path i = + liftIO $ modifyIORef (dirBrowserSelectionMap b) $ \m -> Map.insert path i m + +getSelection :: (MonadIO m) => DirBrowser -> FilePath -> m (Maybe Int) +getSelection b path = + liftIO $ do + st <- readIORef (dirBrowserSelectionMap b) + return $ Map.lookup path st + +load :: DirBrowser -> FilePath -> [FilePath] -> IO () +load b cur entries = + forM_ entries $ \entry -> do + let fullPath = cur entry + f <- getSymbolicLinkStatus fullPath + (attr, _) <- fileAnnotation (dirBrowserSkin b) f cur entry + (_, w) <- addToList (dirBrowserList b) entry + ch <- getSecondChild w + setNormalAttribute ch attr + +descend :: (MonadIO m) => DirBrowser -> Bool -> m () +descend b shouldSelect = do + base <- getDirBrowserPath b + mCur <- getSelected (dirBrowserList b) + case mCur of + Nothing -> return () + Just (_, (p, _)) -> do + let newPath = base p + e <- liftIO $ doesDirectoryExist newPath + case e of + True -> do + cPath <- liftIO $ canonicalizePath newPath + cur <- getDirBrowserPath b + when (cur /= cPath) $ do + case takeDirectory cur == cPath of + True -> ascend b + False -> setDirBrowserPath b cPath + + False -> when shouldSelect $ chooseCurrentEntry b + +ascend :: (MonadIO m) => DirBrowser -> m () +ascend b = do + cur <- liftIO $ getDirBrowserPath b + let newPath = takeDirectory cur + when (newPath /= cur) $ + setDirBrowserPath b newPath diff --git a/src/Graphics/Vty/Widgets/Edit.hs b/src/Graphics/Vty/Widgets/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Edit.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +-- |This module provides a one-line editing interface. +module Graphics.Vty.Widgets.Edit + ( Edit + , editWidget + , getEditText + , setEditText + , setEditCursorPosition + , getEditCursorPosition + , setEditMaxLength + , onActivate + , onChange + , onCursorMove + ) +where + +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Events +import Graphics.Vty.Widgets.Util + +data Edit = Edit { currentText :: String + , cursorPosition :: Int + , displayStart :: Int + , displayWidth :: Int + , activateHandlers :: Handlers (Widget Edit) + , changeHandlers :: Handlers String + , cursorMoveHandlers :: Handlers Int + , maxTextLength :: Maybe Int + } + +instance Show Edit where + show e = concat [ "Edit { " + , "currentText = ", show $ currentText e + , ", cursorPosition = ", show $ cursorPosition e + , ", displayStart = ", show $ displayStart e + , ", displayWidth = ", show $ displayWidth e + , " }" + ] + +-- |Create a new editing widget. +editWidget :: (MonadIO m) => m (Widget Edit) +editWidget = do + ahs <- newHandlers + chs <- newHandlers + cmhs <- newHandlers + + wRef <- newWidget $ \w -> + w { state = Edit { currentText = "" + , cursorPosition = 0 + , displayStart = 0 + , displayWidth = 0 + , activateHandlers = ahs + , changeHandlers = chs + , cursorMoveHandlers = cmhs + , maxTextLength = Nothing + } + + , growHorizontal_ = const $ return True + , getCursorPosition_ = + \this -> do + f <- focused <~ this + pos <- getCurrentPosition this + curPos <- cursorPosition <~~ this + start <- displayStart <~~ this + + if f then + return (Just $ pos `plusWidth` (toEnum (curPos - start))) else + return Nothing + + , render_ = + \this size ctx -> do + setDisplayWidth this (fromEnum $ region_width size) + st <- getState this + + let truncated = take (displayWidth st) + (drop (displayStart st) (currentText st)) + + nAttr = mergeAttrs [ overrideAttr ctx + , normalAttr ctx + ] + + isFocused <- focused <~ this + let attr = if isFocused then focusAttr ctx else nAttr + + return $ string attr truncated + <|> char_fill attr ' ' (region_width size - (toEnum $ length truncated)) 1 + + , keyEventHandler = editKeyEvent + } + setNormalAttribute wRef $ style underline + setFocusAttribute wRef $ style underline + return wRef + +-- |Set the maximum length of the edit widget's content. +setEditMaxLength :: (MonadIO m) => Widget Edit -> Int -> m () +setEditMaxLength wRef v = do + cur <- maxTextLength <~~ wRef + case cur of + Nothing -> return () + Just oldMax -> + when (v < oldMax) $ + do + s <- currentText <~~ wRef + setEditText wRef $ take v s + updateWidgetState wRef $ \s -> s { maxTextLength = Just v } + +-- |Register handlers to be invoked when the edit widget has been +-- ''activated'' (when the user presses Enter while the widget is +-- focused). +onActivate :: (MonadIO m) => Widget Edit -> (Widget Edit -> IO ()) -> m () +onActivate = addHandler (activateHandlers <~~) + +notifyActivateHandlers :: (MonadIO m) => Widget Edit -> m () +notifyActivateHandlers wRef = fireEvent wRef (activateHandlers <~~) wRef + +notifyChangeHandlers :: Widget Edit -> IO () +notifyChangeHandlers wRef = do + s <- getEditText wRef + fireEvent wRef (changeHandlers <~~) s + +notifyCursorMoveHandlers :: (MonadIO m) => Widget Edit -> m () +notifyCursorMoveHandlers wRef = do + pos <- getEditCursorPosition wRef + fireEvent wRef (cursorMoveHandlers <~~) pos + +-- |Register handlers to be invoked when the edit widget's contents +-- change. Handlers will be passed the new contents. +onChange :: (MonadIO m) => Widget Edit -> (String -> IO ()) -> m () +onChange = addHandler (changeHandlers <~~) + +-- |Register handlers to be invoked when the edit widget's cursor +-- position changes. Handlers will be passed the new cursor position, +-- relative to the beginning of the string (position 0). +onCursorMove :: (MonadIO m) => Widget Edit -> (Int -> IO ()) -> m () +onCursorMove = addHandler (cursorMoveHandlers <~~) + +-- |Get the current contents of the edit widget. +getEditText :: (MonadIO m) => Widget Edit -> m String +getEditText = (currentText <~~) + +-- |Set the contents of the edit widget. +setEditText :: (MonadIO m) => Widget Edit -> String -> m () +setEditText wRef str = do + oldS <- currentText <~~ wRef + maxLen <- maxTextLength <~~ wRef + s <- case maxLen of + Nothing -> return str + Just l -> return $ take l str + updateWidgetState wRef $ \st -> st { currentText = s } + when (oldS /= s) $ + liftIO $ do + gotoBeginning wRef + notifyChangeHandlers wRef + +-- |Set the current edit widget cursor position. Invalid cursor +-- positions will be ignored. +setEditCursorPosition :: (MonadIO m) => Widget Edit -> Int -> m () +setEditCursorPosition wRef pos = do + oldPos <- getEditCursorPosition wRef + str <- getEditText wRef + + let newPos = if pos > (length str) + then length str + else if pos < 0 + then 0 + else pos + + when (newPos /= oldPos) $ + do + updateWidgetState wRef $ \s -> + s { cursorPosition = newPos + } + liftIO $ notifyCursorMoveHandlers wRef + +-- |Get the edit widget's current cursor position. +getEditCursorPosition :: (MonadIO m) => Widget Edit -> m Int +getEditCursorPosition = (cursorPosition <~~) + +setDisplayWidth :: Widget Edit -> Int -> IO () +setDisplayWidth this width = + updateWidgetState this $ \s -> + let newDispStart = if cursorPosition s - displayStart s >= width + then cursorPosition s - width + 1 + else displayStart s + in s { displayWidth = width + , displayStart = newDispStart + } + +editKeyEvent :: Widget Edit -> Key -> [Modifier] -> IO Bool +editKeyEvent this k mods = do + case (k, mods) of + (KASCII 'a', [MCtrl]) -> gotoBeginning this >> return True + (KASCII 'k', [MCtrl]) -> killToEOL this >> return True + (KASCII 'e', [MCtrl]) -> gotoEnd this >> return True + (KASCII 'd', [MCtrl]) -> delCurrentChar this >> return True + (KLeft, []) -> moveCursorLeft this >> return True + (KRight, []) -> moveCursorRight this >> return True + (KBS, []) -> deletePreviousChar this >> return True + (KDel, []) -> delCurrentChar this >> return True + (KASCII ch, []) -> insertChar this ch >> return True + (KHome, []) -> gotoBeginning this >> return True + (KEnd, []) -> gotoEnd this >> return True + (KEnter, []) -> notifyActivateHandlers this >> return True + _ -> return False + +killToEOL :: Widget Edit -> IO () +killToEOL this = do + -- Preserve some state since setEditText changes it. + pos <- cursorPosition <~~ this + st <- displayStart <~~ this + str <- getEditText this + + setEditText this $ take pos str + updateWidgetState this $ \s -> + s { displayStart = st + } + + notifyChangeHandlers this + +deletePreviousChar :: Widget Edit -> IO () +deletePreviousChar this = do + pos <- cursorPosition <~~ this + when (pos /= 0) $ do + moveCursorLeft this + delCurrentChar this + +gotoBeginning :: Widget Edit -> IO () +gotoBeginning wRef = do + updateWidgetState wRef $ \s -> s { displayStart = 0 + } + setEditCursorPosition wRef 0 + +gotoEnd :: Widget Edit -> IO () +gotoEnd wRef = do + updateWidgetState wRef $ \s -> + s { displayStart = if (length $ currentText s) > displayWidth s + then (length $ currentText s) - displayWidth s + else 0 + } + s <- getEditText wRef + setEditCursorPosition wRef $ length s + +moveCursorLeft :: Widget Edit -> IO () +moveCursorLeft wRef = do + st <- getState wRef + + case cursorPosition st of + 0 -> return () + p -> do + let newDispStart = if p == displayStart st + then displayStart st - 1 + else displayStart st + updateWidgetState wRef $ \s -> + s { cursorPosition = p - 1 + , displayStart = newDispStart + } + notifyCursorMoveHandlers wRef + +moveCursorRight :: Widget Edit -> IO () +moveCursorRight wRef = do + st <- getState wRef + + when (cursorPosition st < (length $ currentText st)) $ + do + let newDispStart = if cursorPosition st == displayStart st + displayWidth st - 1 + then displayStart st + 1 + else displayStart st + updateWidgetState wRef $ \s -> + s { cursorPosition = cursorPosition st + 1 + , displayStart = newDispStart + } + notifyCursorMoveHandlers wRef + +insertChar :: Widget Edit -> Char -> IO () +insertChar wRef ch = do + maxLen <- maxTextLength <~~ wRef + curLen <- (length . currentText) <~~ wRef + let proceed = case maxLen of + Nothing -> True + Just v -> if curLen + 1 > v + then False + else True + + when proceed $ do + updateWidgetState wRef $ \st -> + let newContent = inject (cursorPosition st) ch (currentText st) + newViewStart = + if cursorPosition st == displayStart st + displayWidth st - 1 + then displayStart st + 1 + else displayStart st + in st { currentText = newContent + , displayStart = newViewStart + } + moveCursorRight wRef + notifyChangeHandlers wRef + +delCurrentChar :: Widget Edit -> IO () +delCurrentChar wRef = do + st <- getState wRef + when (cursorPosition st < (length $ currentText st)) $ + do + let newContent = remove (cursorPosition st) (currentText st) + updateWidgetState wRef $ \s -> s { currentText = newContent } + notifyChangeHandlers wRef + +remove :: Int -> [a] -> [a] +remove pos as = (take pos as) ++ (drop (pos + 1) as) + +inject :: Int -> a -> [a] -> [a] +inject pos a as = let (h, t) = splitAt pos as + in h ++ (a:t) diff --git a/src/Graphics/Vty/Widgets/EventLoop.hs b/src/Graphics/Vty/Widgets/EventLoop.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/EventLoop.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-} +-- |This module provides the main event loop functionality for this +-- library. All vty-ui applications must use runUi to get anything +-- done usefully. +module Graphics.Vty.Widgets.EventLoop + ( Collection + , CollectionError(..) + , runUi + , schedule + , newCollection + , addToCollection + , setCurrentEntry + ) +where + +import Data.IORef +import Data.Typeable +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import System.IO.Unsafe ( unsafePerformIO ) +import Graphics.Vty +import Graphics.Vty.Widgets.Core + +data CombinedEvent = VTYEvent Event + | UserEvent UserEvent + +data UserEvent = ScheduledAction (IO ()) + +eventChan :: Chan CombinedEvent +{-# NOINLINE eventChan #-} +eventChan = unsafePerformIO newChan + +-- |Run the main vty-ui event loop using the specified interface +-- collection and initial rendering context. The rendering context +-- provides the default attributes and 'Skin' to use for the +-- application. Throws 'BadCollectionIndex' if the specified +-- 'Collection' is empty. +runUi :: (MonadIO m) => Collection -> RenderContext -> m () +runUi collection ctx = + liftIO $ do + vty <- mkVty + + -- Create VTY event listener thread + _ <- forkIO $ vtyEventListener vty eventChan + + runUi' vty eventChan collection ctx `finally` do + reserve_display $ terminal vty + shutdown vty + +vtyEventListener :: Vty -> Chan CombinedEvent -> IO () +vtyEventListener vty chan = + forever $ do + e <- next_event vty + writeChan chan $ VTYEvent e + +-- |Schedule a widget-mutating 'IO' action to be run by the main event +-- loop. Use of this function is required to guarantee consistency +-- between interface presentation and internal state. +schedule :: (MonadIO m) => IO () -> m () +schedule act = liftIO $ writeChan eventChan $ UserEvent $ ScheduledAction act + +runUi' :: Vty -> Chan CombinedEvent -> Collection -> RenderContext -> IO () +runUi' vty chan collection ctx = do + sz <- display_bounds $ terminal vty + + e <- getCurrentEntry collection + let fg = entryFocusGroup e + + img <- entryRenderAndPosition e (DisplayRegion 0 0) sz ctx + update vty $ pic_for_image img + + mPos <- getCursorPosition fg + case mPos of + Just (DisplayRegion w h) -> do + show_cursor $ terminal vty + set_cursor_pos (terminal vty) w h + Nothing -> hide_cursor $ terminal vty + + evt <- readChan chan + + case evt of + VTYEvent (EvKey k mods) -> handleKeyEvent fg k mods >> return () + UserEvent (ScheduledAction act) -> liftIO act + _ -> return () + + runUi' vty chan collection ctx + +data CollectionError = BadCollectionIndex Int + deriving (Show, Typeable) + +instance Exception CollectionError + +data Entry = forall a. (Show a) => Entry (Widget a) (Widget FocusGroup) + +data CollectionData = + CollectionData { entries :: [Entry] + , currentEntryNum :: Int + } + +-- |The type of user interface collections. +type Collection = IORef CollectionData + +instance Show CollectionData where + show (CollectionData es num) = concat [ "Collection { " + , "entries = <", show $ length es, "entries>" + , ", currentEntryNum = ", show num + , " }" + ] + +entryRenderAndPosition :: (MonadIO m) => Entry -> DisplayRegion -> DisplayRegion -> RenderContext -> m Image +entryRenderAndPosition (Entry w _) = renderAndPosition w + +entryFocusGroup :: Entry -> Widget FocusGroup +entryFocusGroup (Entry _ fg) = fg + +-- |Create a new collection. +newCollection :: (MonadIO m) => m Collection +newCollection = + liftIO $ newIORef $ CollectionData { entries = [] + , currentEntryNum = -1 + } + +getCurrentEntry :: (MonadIO m) => Collection -> m Entry +getCurrentEntry cRef = do + cur <- currentEntryNum <~ cRef + es <- entries <~ cRef + if cur == -1 then + throw $ BadCollectionIndex cur else + if cur >= 0 && cur < length es then + return $ es !! cur else + throw $ BadCollectionIndex cur + +-- |Add a widget and its focus group to a collection. Returns an +-- action which, when invoked, will switch to the interface specified +-- in the call. +addToCollection :: (MonadIO m, Show a) => Collection -> Widget a -> Widget FocusGroup -> m (m ()) +addToCollection cRef wRef fg = do + i <- (length . entries) <~ cRef + liftIO $ modifyIORef cRef $ \st -> + st { entries = (entries st) ++ [Entry wRef fg] + , currentEntryNum = if currentEntryNum st == -1 + then 0 + else currentEntryNum st + } + resetFocusGroup fg + return $ setCurrentEntry cRef i + +setCurrentEntry :: (MonadIO m) => Collection -> Int -> m () +setCurrentEntry cRef i = do + st <- liftIO $ readIORef cRef + if i < length (entries st) && i >= 0 then + (liftIO $ modifyIORef cRef $ \s -> s { currentEntryNum = i }) else + throw $ BadCollectionIndex i + + e <- getCurrentEntry cRef + resetFocusGroup $ entryFocusGroup e diff --git a/src/Graphics/Vty/Widgets/Events.hs b/src/Graphics/Vty/Widgets/Events.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Events.hs @@ -0,0 +1,45 @@ +-- |This module provides infrastructure for widgets that need to +-- produce events and provide event handler registration +-- functionality. +module Graphics.Vty.Widgets.Events + ( Handlers + , Handler + , newHandlers + , addHandler + , fireEvent + ) +where + +import Control.Monad.Trans +import Control.Monad +import Data.IORef + +-- |The type of event handlers which take a parameter of type 'a'. +type Handler a = a -> IO () + +-- |The type of event handler collections of parameter type 'a'. +newtype Handlers a = Handlers (IORef [Handler a]) + +-- |Given an event handler collection projection combinator, a target, +-- and a handler, add the handler to the target's event handler +-- collection. +addHandler :: (MonadIO m) => (w -> m (Handlers a)) -> w -> Handler a -> m () +addHandler getRef w handler = do + (Handlers r) <- getRef w + liftIO $ modifyIORef r $ \s -> s ++ [handler] + +-- |Fire an event by extracting an event handler collection from a +-- target and invoking all of its handlers with the specified +-- parameter value. +fireEvent :: (MonadIO m) => w -> (w -> m (Handlers a)) -> a -> m () +fireEvent w getRef ev = do + (Handlers r) <- getRef w + handlers <- liftIO $ readIORef r + forM_ handlers $ \handler -> + liftIO $ handler ev + +-- |Create a new event handler collection. +newHandlers :: (MonadIO m) => m (Handlers a) +newHandlers = do + r <- liftIO $ newIORef [] + return $ Handlers r diff --git a/src/Graphics/Vty/Widgets/Fills.hs b/src/Graphics/Vty/Widgets/Fills.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Fills.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +-- |This module provides ''space-filling'' widgets used to control +-- layout. +module Graphics.Vty.Widgets.Fills + ( VFill + , HFill + , hFill + , vFill + ) +where + +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Util + +data VFill = VFill Char + deriving (Show) + +-- |A vertical fill widget. Fills all available space with the +-- specified character and attribute. +vFill :: (MonadIO m) => Char -> m (Widget VFill) +vFill c = do + wRef <- newWidget $ \w -> + w { state = VFill c + , growVertical_ = const $ return True + , render_ = \this s ctx -> do + foc <- focused <~ this + VFill ch <- getState this + let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx + , normalAttr ctx + ] + return $ char_fill attr' ch (region_width s) (region_height s) + } + return wRef + +data HFill = HFill Char Int + deriving (Show) + +-- |A horizontal fill widget. Fills the available horizontal space, +-- one row high, using the specified character and attribute. +hFill :: (MonadIO m) => Char -> Int -> m (Widget HFill) +hFill c h = do + wRef <- newWidget $ \w -> + w { state = HFill c h + , growHorizontal_ = const $ return True + , render_ = \this s ctx -> do + foc <- focused <~ this + HFill ch height <- getState this + let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx + , normalAttr ctx + ] + return $ char_fill attr' ch (region_width s) (toEnum height) + } + return wRef diff --git a/src/Graphics/Vty/Widgets/Fixed.hs b/src/Graphics/Vty/Widgets/Fixed.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Fixed.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- |This module provides wrapper widgets for fixing the size of child +-- widgets in one or more dimensions in rows or columns, respectively. +-- This differs from the ''limit'' widgets in the Limits module in +-- that Limits enforce an upper bound on size. +module Graphics.Vty.Widgets.Fixed + ( VFixed + , HFixed + , hFixed + , vFixed + , boxFixed + , setVFixed + , setHFixed + , addToVFixed + , addToHFixed + , getVFixedSize + , getHFixedSize + ) +where + +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Util + +data HFixed a = (Show a) => HFixed Int (Widget a) + +instance Show (HFixed a) where + show (HFixed i _) = "HFixed { width = " ++ show i ++ ", ... }" + +-- |Impose a fixed horizontal size, in columns, on a 'Widget'. +hFixed :: (MonadIO m, Show a) => Int -> Widget a -> m (Widget (HFixed a)) +hFixed fixedWidth child = do + wRef <- newWidget $ \w -> + w { state = HFixed fixedWidth child + , render_ = \this s ctx -> do + HFixed width ch <- getState this + let region = s `withWidth` fromIntegral (min (toEnum width) (region_width s)) + img <- render ch region ctx + -- Pad the image if it's smaller than the region. + let img' = if image_width img < region_width region + then img <|> (char_fill (getNormalAttr ctx) ' ' + (region_width region - image_width img) + (region_height region)) + else img + return img' + + , setCurrentPosition_ = + \this pos -> do + HFixed _ ch <- getState this + setCurrentPosition ch pos + } + wRef `relayKeyEvents` child + wRef `relayFocusEvents` child + return wRef + +data VFixed a = (Show a) => VFixed Int (Widget a) + +instance Show (VFixed a) where + show (VFixed i _) = "VFixed { height = " ++ show i ++ ", ... }" + +-- |Impose a fixed vertical size, in columns, on a 'Widget'. +vFixed :: (MonadIO m, Show a) => Int -> Widget a -> m (Widget (VFixed a)) +vFixed maxHeight child = do + wRef <- newWidget $ \w -> + w { state = VFixed maxHeight child + , growHorizontal_ = const $ growHorizontal child + + , render_ = \this s ctx -> do + VFixed height ch <- getState this + let region = s `withHeight` fromIntegral (min (toEnum height) (region_height s)) + img <- render ch region ctx + -- Pad the image if it's smaller than the region. + let img' = if image_height img < region_height region + then img <-> (char_fill (getNormalAttr ctx) ' ' + (region_width region) + (region_height region - image_height img)) + else img + return img' + + , setCurrentPosition_ = + \this pos -> do + VFixed _ ch <- getState this + setCurrentPosition ch pos + } + wRef `relayKeyEvents` child + wRef `relayFocusEvents` child + return wRef + +-- |Set the vertical fixed size of a child widget. +setVFixed :: (MonadIO m) => Widget (VFixed a) -> Int -> m () +setVFixed wRef lim = + when (lim >= 1) $ + updateWidgetState wRef $ \(VFixed _ ch) -> VFixed lim ch + +-- |Set the horizontal fixed size of a child widget. +setHFixed :: (MonadIO m) => Widget (HFixed a) -> Int -> m () +setHFixed wRef lim = + when (lim >= 1) $ + updateWidgetState wRef $ \(HFixed _ ch) -> HFixed lim ch + +-- |Add to the vertical fixed size of a child widget. +addToVFixed :: (MonadIO m) => Widget (VFixed a) -> Int -> m () +addToVFixed wRef delta = do + lim <- getVFixedSize wRef + setVFixed wRef $ lim + delta + +-- |Add to the horizontal fixed size of a child widget. +addToHFixed :: (MonadIO m) => Widget (HFixed a) -> Int -> m () +addToHFixed wRef delta = do + lim <- getHFixedSize wRef + setHFixed wRef $ lim + delta + +-- |Get the vertical fixed size of a child widget. +getVFixedSize :: (MonadIO m) => Widget (VFixed a) -> m Int +getVFixedSize wRef = do + (VFixed lim _) <- state <~ wRef + return lim + +-- |Get the horizontal fixed size of a child widget. +getHFixedSize :: (MonadIO m) => Widget (HFixed a) -> m Int +getHFixedSize wRef = do + (HFixed lim _) <- state <~ wRef + return lim + +-- |Impose a maximum horizontal and vertical size on a widget. +boxFixed :: (MonadIO m, Show a) => + Int -- ^Maximum width in columns + -> Int -- ^Maximum height in rows + -> Widget a + -> m (Widget (VFixed (HFixed a))) +boxFixed maxWidth maxHeight w = do + ch <- hFixed maxWidth w + vFixed maxHeight ch diff --git a/src/Graphics/Vty/Widgets/Limits.hs b/src/Graphics/Vty/Widgets/Limits.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Limits.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- |This module provides wrapper widgets for enforcing an upper bound +-- on the size of child widgets in one or more dimensions in rows or +-- columns, respectively. This differs from the ''fixed'' widgets in +-- the Fixed module in that Fixed widgets enforce a fixed size +-- regardless of how big or small the child widget is, and add padding +-- to guarantee that the fixed size is honored. +module Graphics.Vty.Widgets.Limits + ( VLimit + , HLimit + , hLimit + , vLimit + , boxLimit + , setVLimit + , setHLimit + , addToVLimit + , addToHLimit + , getVLimit + , getHLimit + ) +where + +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Util + +data HLimit a = (Show a) => HLimit Int (Widget a) + +instance Show (HLimit a) where + show (HLimit i _) = "HLimit { width = " ++ show i ++ ", ... }" + +-- |Impose a maximum horizontal size, in columns, on a 'Widget'. +hLimit :: (MonadIO m, Show a) => Int -> Widget a -> m (Widget (HLimit a)) +hLimit maxWidth child = do + wRef <- newWidget $ \w -> + w { state = HLimit maxWidth child + , growHorizontal_ = const $ return False + , growVertical_ = const $ growVertical child + , render_ = \this s ctx -> do + HLimit width ch <- getState this + let region = s `withWidth` fromIntegral (min (toEnum width) (region_width s)) + render ch region ctx + + , setCurrentPosition_ = + \this pos -> do + HLimit _ ch <- getState this + setCurrentPosition ch pos + } + wRef `relayKeyEvents` child + wRef `relayFocusEvents` child + return wRef + +data VLimit a = (Show a) => VLimit Int (Widget a) + +instance Show (VLimit a) where + show (VLimit i _) = "VLimit { height = " ++ show i ++ ", ... }" + +-- |Impose a maximum vertical size, in columns, on a 'Widget'. +vLimit :: (MonadIO m, Show a) => Int -> Widget a -> m (Widget (VLimit a)) +vLimit maxHeight child = do + wRef <- newWidget $ \w -> + w { state = VLimit maxHeight child + , growHorizontal_ = const $ growHorizontal child + , growVertical_ = const $ return False + + , render_ = \this s ctx -> do + VLimit height ch <- getState this + let region = s `withHeight` fromIntegral (min (toEnum height) (region_height s)) + render ch region ctx + + , setCurrentPosition_ = + \this pos -> do + VLimit _ ch <- getState this + setCurrentPosition ch pos + } + wRef `relayKeyEvents` child + wRef `relayFocusEvents` child + return wRef + +-- |Set the vertical limit of a child widget's size. +setVLimit :: (MonadIO m) => Widget (VLimit a) -> Int -> m () +setVLimit wRef lim = + when (lim >= 1) $ + updateWidgetState wRef $ \(VLimit _ ch) -> VLimit lim ch + +-- |Set the horizontal limit of a child widget's size. +setHLimit :: (MonadIO m) => Widget (HLimit a) -> Int -> m () +setHLimit wRef lim = + when (lim >= 1) $ + updateWidgetState wRef $ \(HLimit _ ch) -> HLimit lim ch + +-- |Add to the vertical limit of a child widget's size. +addToVLimit :: (MonadIO m) => Widget (VLimit a) -> Int -> m () +addToVLimit wRef delta = do + lim <- getVLimit wRef + setVLimit wRef $ lim + delta + +-- |Add to the horizontal limit of a child widget's size. +addToHLimit :: (MonadIO m) => Widget (HLimit a) -> Int -> m () +addToHLimit wRef delta = do + lim <- getHLimit wRef + setHLimit wRef $ lim + delta + +-- |Get the vertical limit of a child widget's size. +getVLimit :: (MonadIO m) => Widget (VLimit a) -> m Int +getVLimit wRef = do + (VLimit lim _) <- state <~ wRef + return lim + +-- |Get the horizontal limit of a child widget's size. +getHLimit :: (MonadIO m) => Widget (HLimit a) -> m Int +getHLimit wRef = do + (HLimit lim _) <- state <~ wRef + return lim + +-- |Impose a horizontal and vertical upper bound on the size of a +-- widget. +boxLimit :: (MonadIO m, Show a) => + Int -- ^Maximum width in columns + -> Int -- ^Maximum height in rows + -> Widget a + -> m (Widget (VLimit (HLimit a))) +boxLimit maxWidth maxHeight w = do + ch <- hLimit maxWidth w + vLimit maxHeight ch diff --git a/src/Graphics/Vty/Widgets/List.hs b/src/Graphics/Vty/Widgets/List.hs --- a/src/Graphics/Vty/Widgets/List.hs +++ b/src/Graphics/Vty/Widgets/List.hs @@ -1,212 +1,509 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} -- |This module provides a 'List' widget for rendering a list of --- arbitrary widgets. A 'List' has the following features: --- --- * A style for the list elements --- --- * A styled cursor indicating which element is selected --- --- * A /window size/ indicating how many elements should be visible to --- the user --- --- * An internal pointer to the start of the visible window, which --- automatically shifts as the list is scrolled +-- arbitrary widgets. A 'List' shows a number of elements and +-- highlights the currently-selected widget. It supports key events +-- to navigate the list and will automatically scroll based on the +-- space available to the list along with the size of the widgets in +-- the list. module Graphics.Vty.Widgets.List ( List , ListItem + , ListError(..) + , NewItemEvent(..) + , RemoveItemEvent(..) + , SelectionEvent(..) + , ActivateItemEvent(..) -- ** List creation - , mkList - , mkSimpleList - , listWidget + , newStringList + , newList + , addToList + , removeFromList -- ** List manipulation , scrollBy , scrollUp , scrollDown , pageUp , pageDown - , resize + , onSelectionChange + , onItemAdded + , onItemRemoved + , onItemActivated + , activateCurrentItem + , clearList -- ** List inspection - , listItems + , getListSize , getSelected - , selectedIndex - , scrollTopIndex - , scrollWindowSize - , getVisibleItems ) where -import Graphics.Vty ( Attr, DisplayRegion ) -import Graphics.Vty.Widgets.Rendering - ( Widget(..) - , Orientation(..) - , Render - ) -import Graphics.Vty.Widgets.Rendering - ( renderMany - ) -import Graphics.Vty.Widgets.Base - ( hFill - ) +import Data.Typeable +import Control.Exception hiding (Handler) +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Text - ( simpleText - ) +import Graphics.Vty.Widgets.Events +import Graphics.Vty.Widgets.Util --- |A list item. Each item contains an arbitrary internal identifier --- @a@ and a 'Widget' representing it. -type ListItem a = (a, Widget) +data ListError = BadItemIndex Int + -- ^The specified position could not be used to remove + -- an item from the list. + | ResizeError + | BadListWidgetSizePolicy + -- ^The type of widgets added to the list grow + -- vertically, which is not permitted. + deriving (Show, Typeable) +instance Exception ListError + +-- |A list item. Each item contains an arbitrary internal value @a@ +-- and a 'Widget' representing it. +type ListItem a b = (a, Widget b) + +data SelectionEvent a b = SelectionOn Int a (Widget b) + -- ^An item at the specified position with the + -- specified internal value and widget was + -- selected. + | SelectionOff + -- ^No item was selected, which means the + -- list is empty. + +-- |A new item was added to the list at the specified position with +-- the specified value and widget. +data NewItemEvent a b = NewItemEvent Int a (Widget b) + +-- |An item was removed from the list at the specified position with +-- the specified value and widget. +data RemoveItemEvent a b = RemoveItemEvent Int a (Widget b) + +-- |An item in the list was activated at the specified position with +-- the specified value and widget. +data ActivateItemEvent a b = ActivateItemEvent Int a (Widget b) + -- |The list widget type. Lists are parameterized over the /internal/ --- /identifier type/ @a@, the type of internal identifiers used to --- refer to the visible representations of the list contents, and the --- /widget type/ @b@, the type of widgets used to represent the list --- visually. -data List a = List { normalAttr :: Attr - , selectedAttr :: Attr - , selectedIndex :: Int - -- ^The currently selected list index. - , scrollTopIndex :: Int - -- ^The start index of the window of visible list - -- items. - , scrollWindowSize :: Int - -- ^The size of the window of visible list items. - , listItems :: [ListItem a] - -- ^The items in the list. - } +-- /value type/ @a@, the type of internal values used to refer to the +-- visible representations of the list contents, and the /widget type/ +-- @b@, the type of widgets used to represent the list visually. +data List a b = List { selectedUnfocusedAttr :: Attr + , selectedIndex :: Int + -- ^The currently selected list index. + , scrollTopIndex :: Int + -- ^The start index of the window of visible list + -- items. + , scrollWindowSize :: Int + -- ^The size of the window of visible list items. + , listItems :: [ListItem a b] + -- ^The items in the list. + , selectionChangeHandlers :: Handlers (SelectionEvent a b) + , itemAddHandlers :: Handlers (NewItemEvent a b) + , itemRemoveHandlers :: Handlers (RemoveItemEvent a b) + , itemActivateHandlers :: Handlers (ActivateItemEvent a b) + , itemHeight :: Int + , itemConstructor :: a -> IO (Widget b) + -- ^Function to construct new items + } --- |Create a new list. Emtpy lists and empty scrolling windows are --- not allowed. -mkList :: Attr -- ^The attribute of normal, non-selected items - -> Attr -- ^The attribute of the selected item - -> Int -- ^The scrolling window size, i.e., the number of items - -- which should be visible to the user at any given time - -> [ListItem a] -- ^The list items - -> List a -mkList _ _ _ [] = error "Lists cannot be empty" -mkList normAttr selAttr swSize contents - | swSize <= 0 = error "Scrolling window size must be > 0" - | otherwise = List normAttr selAttr 0 0 swSize contents +instance Show (List a b) where + show lst = concat [ "List { " + , "selectedUnfocusedAttr = ", show $ selectedUnfocusedAttr lst + , ", selectedIndex = ", show $ selectedIndex lst + , ", scrollTopIndex = ", show $ scrollTopIndex lst + , ", scrollWindowSize = ", show $ scrollWindowSize lst + , ", listItems = <", show $ length $ listItems lst, " items>" + , ", itemHeight = ", show $ itemHeight lst + , " }" + ] -listWidget :: List a -> Widget -listWidget list = Widget { - growHorizontal = False - , growVertical = False - , withAttribute = \att -> listWidget list { normalAttr = att } - , primaryAttribute = normalAttr list - , render = renderListWidget list - } +newListData :: (MonadIO m) => + Attr -- ^The attribute of the selected item + -> (a -> IO (Widget b)) -- ^Constructor for new item widgets + -> m (List a b) +newListData selAttr f = do + schs <- newHandlers + iahs <- newHandlers + irhs <- newHandlers + iacths <- newHandlers -renderListWidget :: List a -> DisplayRegion -> Render -renderListWidget list s = - renderMany Vertical ws - where - ws = map (\w -> render w s) (visible ++ filler) - visible = map highlight items - items = map (\((_, w), sel) -> (w, sel)) $ getVisibleItems list - filler = replicate (scrollWindowSize list - length visible) - (hFill (normalAttr list) ' ' 1) - highlight (w, selected) = let att = if selected - then selectedAttr - else normalAttr - in withAttribute w (att list) + return $ List { selectedUnfocusedAttr = selAttr + , selectedIndex = -1 + , scrollTopIndex = 0 + , scrollWindowSize = 0 + , listItems = [] + , selectionChangeHandlers = schs + , itemAddHandlers = iahs + , itemRemoveHandlers = irhs + , itemActivateHandlers = iacths + , itemHeight = 0 + , itemConstructor = f + } +-- |Get the length of the list in elements. +getListSize :: (MonadIO m) => Widget (List a b) -> m Int +getListSize = ((length . listItems) <~~) + +-- |Remove an element from the list at the specified position. May +-- throw 'BadItemIndex'. +removeFromList :: (MonadIO m) => Widget (List a b) -> Int -> m (ListItem a b) +removeFromList list pos = do + st <- getState list + + let numItems = length $ listItems st + + when (pos < 0 || pos >= numItems) $ + throw $ BadItemIndex pos + + -- Get the item from the list. + let (label, w) = listItems st !! pos + sel = selectedIndex st + + -- If that item is currently selected, select a different item. + newSelectedIndex = if pos > sel + then pos + else if pos < sel + then if sel == 0 + then 0 + else sel - 1 + else if sel == 0 + then if numItems == 1 + then (-1) + else 0 + else if sel == numItems - 1 + then sel - 1 + else sel + + updateWidgetState list $ \s -> s { selectedIndex = newSelectedIndex + , listItems = take pos (listItems st) ++ + drop (pos + 1) (listItems st) + } + + -- Notify the removal handler. + notifyItemRemoveHandler list pos label w + + -- Notify the selection handler, but only if the position we deleted + -- from is the selected position; that means the selection changed. + -- + -- XXX this should probably be ==, not <=. Do some testing. + when (pos <= selectedIndex st) $ + notifySelectionHandler list + + -- Return the removed item. + return (label, w) + +-- |Add an item to the list. Its widget will be constructed from the +-- specified internal value using the widget constructor passed to +-- 'newList'. +addToList :: (MonadIO m, Show b) => Widget (List a b) -> a -> m (ListItem a b) +addToList list key = do + numItems <- (length . listItems) <~~ list + + makeWidget <- itemConstructor <~~ list + w <- liftIO $ makeWidget key + + v <- growVertical w + when (v) $ throw BadListWidgetSizePolicy + + h <- case numItems of + 0 -> do + -- We're adding the first element to the list, so we need + -- to compute the item height based on this widget. We + -- just render it in an unreasonably large space (since, + -- really, list items should never be THAT big) and measure + -- the result, assuming that all list widgets will have the + -- same size. If you violate this, you'll have interesting + -- results! + img <- render w (DisplayRegion 100 100) defaultContext + return $ fromEnum $ image_height img + _ -> itemHeight <~~ list + + updateWidgetState list $ \s -> s { itemHeight = h + , listItems = listItems s ++ [(key, w)] + , selectedIndex = if numItems == 0 + then 0 + else selectedIndex s + } + + notifyItemAddHandler list (numItems + 1) key w + + when (numItems == 0) $ + notifySelectionHandler list + + return (key, w) + +-- |Register event handlers to be invoked when the list's selected +-- item changes. +onSelectionChange :: (MonadIO m) => + Widget (List a b) + -> (SelectionEvent a b -> IO ()) + -> m () +onSelectionChange = addHandler (selectionChangeHandlers <~~) + +-- |Register event handlers to be invoked when a new item is added to +-- the list. +onItemAdded :: (MonadIO m) => Widget (List a b) + -> (NewItemEvent a b -> IO ()) -> m () +onItemAdded = addHandler (itemAddHandlers <~~) + +-- |Register event handlers to be invoked when an item is removed from +-- the list. +onItemRemoved :: (MonadIO m) => Widget (List a b) + -> (RemoveItemEvent a b -> IO ()) -> m () +onItemRemoved = addHandler (itemRemoveHandlers <~~) + +-- |Register event handlers to be invoked when an item is activated, +-- which happens when the user presses Enter on a selected element +-- while the list has the focus. +onItemActivated :: (MonadIO m) => Widget (List a b) + -> (ActivateItemEvent a b -> IO ()) -> m () +onItemActivated = addHandler (itemActivateHandlers <~~) + +-- |Clear the list, removing all elements. Does not invoke any +-- handlers. +clearList :: (MonadIO m) => Widget (List a b) -> m () +clearList w = do + updateWidgetState w $ \l -> + l { selectedIndex = 0 + , scrollTopIndex = 0 + , listItems = [] + } + +-- |Create a new list using the specified attribute for the +-- currently-selected element when the list does NOT have focus. Use +-- the specified constructor function to create widgets for new items +-- in the list. +newList :: (MonadIO m, Show b) => + Attr -- ^The attribute of the selected item + -> (a -> IO (Widget b)) -- ^Constructor for new item widgets + -> m (Widget (List a b)) +newList selAttr f = do + list <- newListData selAttr f + wRef <- newWidget $ \w -> + w { state = list + , keyEventHandler = listKeyEvent + + , growVertical_ = const $ return True + , growHorizontal_ = const $ return True + + , getCursorPosition_ = + \this -> do + st <- getState this + pos <- getCurrentPosition this + sz <- getCurrentSize this + let newCol = max 0 (region_width pos + region_width sz - 1) + newRow = region_height pos + toEnum (max 0 $ selectedIndex st - scrollTopIndex st) + return $ Just (pos `withWidth` newCol `withHeight` newRow) + + , render_ = + \this sz ctx -> do + -- Get the item height *before* a potential resize, then + -- get the list state below, after the resize. + h <- itemHeight <~~ this + + -- Resize the list based on the available space and the + -- height of each item. + when (h > 0) $ + resize this (max 1 ((fromEnum $ region_height sz) `div` h)) + + listData <- getState this + foc <- focused <~ this + + renderListWidget foc listData sz ctx + + , setCurrentPosition_ = + \this pos -> do + ih <- itemHeight <~~ this + items <- getVisibleItems this + forM_ (zip [0..] items) $ \(i, ((_, iw), _)) -> + setCurrentPosition iw (pos `plusHeight` (toEnum $ i * ih)) + } + return wRef + +listKeyEvent :: Widget (List a b) -> Key -> [Modifier] -> IO Bool +listKeyEvent w KUp _ = scrollUp w >> return True +listKeyEvent w KDown _ = scrollDown w >> return True +listKeyEvent w KPageUp _ = pageUp w >> return True +listKeyEvent w KPageDown _ = pageDown w >> return True +listKeyEvent w KEnter _ = activateCurrentItem w >> return True +listKeyEvent _ _ _ = return False + +renderListWidget :: (Show b) => Bool -> List a b -> DisplayRegion -> RenderContext -> IO Image +renderListWidget foc list s ctx = do + let items = map (\((_, w), sel) -> (w, sel)) $ getVisibleItems_ list + defaultAttr = mergeAttrs [ overrideAttr ctx + , normalAttr ctx + ] + + renderVisible [] = return [] + renderVisible ((w, sel):ws) = do + let att = if sel + then if foc + then focusAttr ctx + else mergeAttrs [ selectedUnfocusedAttr list + , defaultAttr + ] + else defaultAttr + img <- render w s $ ctx { overrideAttr = att } + + let actualHeight = min (region_height s) (toEnum $ itemHeight list) + img' = img <|> char_fill att ' ' + (region_width s - image_width img) + actualHeight + imgs <- renderVisible ws + return (img':imgs) + + let filler = char_fill defaultAttr ' ' (region_width s) fill_height + fill_height = if scrollWindowSize list == 0 + then region_height s + else toEnum $ ((scrollWindowSize list - length items) * itemHeight list) + + visible_imgs <- renderVisible items + + return $ vert_cat (visible_imgs ++ [filler]) + -- |A convenience function to create a new list using 'String's as the --- internal identifiers and 'Text' widgets to represent those strings. -mkSimpleList :: Attr -- ^The attribute of normal, non-selected items - -> Attr -- ^The attribute of the selected item - -> Int -- ^The scrolling window size, i.e., the number of - -- items which should be visible to the user at - -- any given time - -> [String] -- ^The list items - -> List String -mkSimpleList normAttr selAttr swSize labels = - mkList normAttr selAttr swSize widgets - where - widgets = map (\l -> (l, simpleText normAttr l)) labels +-- internal values and 'FormattedText' widgets to represent those +-- strings. +newStringList :: (MonadIO m) => + Attr -- ^The attribute of the selected item + -> [String] -- ^The list items + -> m (Widget (List String FormattedText)) +newStringList selAttr labels = do + list <- newList selAttr plainText + mapM_ (addToList list) labels + return list +-- |Programmatically activate the currently-selected item in the list, +-- if any. +activateCurrentItem :: (MonadIO m) => Widget (List a b) -> m () +activateCurrentItem wRef = do + mSel <- getSelected wRef + case mSel of + Nothing -> return () + Just (pos, (val, w)) -> + fireEvent wRef (itemActivateHandlers <~~) $ ActivateItemEvent pos val w + -- note that !! here will always succeed because selectedIndex will -- never be out of bounds and the list will always be non-empty. --- |Get the currently selected list item. -getSelected :: List a -> ListItem a -getSelected list = (listItems list) !! (selectedIndex list) +-- |Get the currently-selected list item. +getSelected :: (MonadIO m) => Widget (List a b) -> m (Maybe (Int, ListItem a b)) +getSelected wRef = do + list <- state <~ wRef + case selectedIndex list of + (-1) -> return Nothing + i -> return $ Just (i, (listItems list) !! i) --- |Set the window size of the list. This automatically adjusts the --- window position to keep the selected item visible. -resize :: Int -> List a -> List a -resize newSize list - | newSize == 0 = error "Cannot resize list window to zero" - -- Do nothing if the window size isn't changing. - | newSize == scrollWindowSize list = list - -- If the new window size is larger, just set it. - | newSize > scrollWindowSize list = list { scrollWindowSize = newSize } +resize :: (MonadIO m) => Widget (List a b) -> Int -> m () +resize wRef newSize = do + when (newSize == 0) $ throw ResizeError + + size <- (scrollWindowSize . state) <~ wRef + + case compare newSize size of + EQ -> return () -- Do nothing if the window size isn't changing. + GT -> updateWidgetState wRef $ \list -> + list { scrollWindowSize = newSize + , scrollTopIndex = max 0 (scrollTopIndex list - (newSize - scrollWindowSize list)) + } -- Otherwise it's smaller, so we need to look at which item is -- selected and decide whether to change the scrollTopIndex. - | otherwise = list { scrollWindowSize = newSize - , selectedIndex = newSelected - } - where - newBottomPosition = scrollTopIndex list + newSize - 1 - current = selectedIndex list - newSelected = if current > newBottomPosition - then newBottomPosition - else current + LT -> do + list <- state <~ wRef --- |Scroll a list up or down by the specified number of positions and --- return the new scrolled list. Scrolling by a positive amount --- scrolls downward and scrolling by a negative amount scrolls upward. --- This automatically takes care of managing internal list state: --- --- * Moves the cursor by the specified amount and clamps the cursor --- position to the beginning or the end of the list where --- appropriate --- --- * Moves the scrolling window position if necessary (i.e., if the --- cursor moves to an item not currently in view) -scrollBy :: Int -> List a -> List a -scrollBy amount list = - list { scrollTopIndex = adjustedTop - , selectedIndex = newSelected } - where - sel = selectedIndex list - lastPos = (length $ listItems list) - 1 - validPositions = [0..lastPos] - newPosition = sel + amount + -- If the currently selected item would be out of view in the + -- new size, then we need to move the display top down to keep + -- it visible. + let newBottomPosition = scrollTopIndex list + newSize - 1 + current = selectedIndex list + newScrollTopIndex = if current > newBottomPosition + then current - newSize + 1 + else scrollTopIndex list - newSelected = if newPosition `elem` validPositions - then newPosition - else if newPosition > lastPos - then lastPos - else 0 + updateWidgetState wRef $ const $ list { scrollWindowSize = newSize + , scrollTopIndex = newScrollTopIndex + } - bottomPosition = scrollTopIndex list + scrollWindowSize list - 1 - topPosition = scrollTopIndex list - windowPositions = [topPosition..bottomPosition] +-- |Scroll a list up or down by the specified number of positions. +-- Scrolling by a positive amount scrolls downward and scrolling by a +-- negative amount scrolls upward. This automatically takes care of +-- managing internal list state and invoking event handlers. +scrollBy :: (MonadIO m) => Widget (List a b) -> Int -> m () +scrollBy wRef amount = do + updateWidgetState wRef $ scrollBy' amount + notifySelectionHandler wRef - adjustedTop = if newPosition `elem` windowPositions - then topPosition - else if newSelected >= bottomPosition - then newSelected - scrollWindowSize list + 1 - else newSelected +scrollBy' :: Int -> List a b -> List a b +scrollBy' amount list = + let sel = selectedIndex list + lastPos = (length $ listItems list) - 1 + validPositions = [0..lastPos] + newPosition = sel + amount + newSelected = if newPosition `elem` validPositions + then newPosition + else if newPosition > lastPos + then lastPos + else 0 + + bottomPosition = min (scrollTopIndex list + scrollWindowSize list - 1) + ((length $ listItems list) - 1) + topPosition = scrollTopIndex list + windowPositions = [topPosition..bottomPosition] + + adjustedTop = if newSelected `elem` windowPositions + then topPosition + else if newSelected >= bottomPosition + then newSelected - scrollWindowSize list + 1 + else newSelected + + in if scrollWindowSize list == 0 + then list + else list { scrollTopIndex = adjustedTop + , selectedIndex = newSelected } + +notifySelectionHandler :: (MonadIO m) => Widget (List a b) -> m () +notifySelectionHandler wRef = do + sel <- getSelected wRef + case sel of + Nothing -> + fireEvent wRef (selectionChangeHandlers <~~) SelectionOff + Just (pos, (a, b)) -> + fireEvent wRef (selectionChangeHandlers <~~) $ SelectionOn pos a b + +notifyItemRemoveHandler :: (MonadIO m) => Widget (List a b) -> Int -> a -> Widget b -> m () +notifyItemRemoveHandler wRef pos k w = + fireEvent wRef (itemRemoveHandlers <~~) $ RemoveItemEvent pos k w + +notifyItemAddHandler :: (MonadIO m) => Widget (List a b) -> Int -> a -> Widget b -> m () +notifyItemAddHandler wRef pos k w = + fireEvent wRef (itemAddHandlers <~~) $ NewItemEvent pos k w + -- |Scroll a list down by one position. -scrollDown :: List a -> List a -scrollDown = scrollBy 1 +scrollDown :: (MonadIO m) => Widget (List a b) -> m () +scrollDown wRef = scrollBy wRef 1 -- |Scroll a list up by one position. -scrollUp :: List a -> List a -scrollUp = scrollBy (-1) +scrollUp :: (MonadIO m) => Widget (List a b) -> m () +scrollUp wRef = scrollBy wRef (-1) -- |Scroll a list down by one page from the current cursor position. -pageDown :: List a -> List a -pageDown list = scrollBy (scrollWindowSize list) list +pageDown :: (MonadIO m) => Widget (List a b) -> m () +pageDown wRef = do + amt <- scrollWindowSize <~~ wRef + scrollBy wRef amt -- |Scroll a list up by one page from the current cursor position. -pageUp :: List a -> List a -pageUp list = scrollBy (-1 * scrollWindowSize list) list +pageUp :: (MonadIO m) => Widget (List a b) -> m () +pageUp wRef = do + amt <- scrollWindowSize <~~ wRef + scrollBy wRef (-1 * amt) --- |Given a 'List', return the items that are currently visible --- according to the state of the list. Returns the visible items and --- flags indicating whether each is selected. -getVisibleItems :: List a -> [(ListItem a, Bool)] -getVisibleItems list = +getVisibleItems :: (MonadIO m) => Widget (List a b) -> m [(ListItem a b, Bool)] +getVisibleItems wRef = do + list <- state <~ wRef + return $ getVisibleItems_ list + +getVisibleItems_ :: List a b -> [(ListItem a b, Bool)] +getVisibleItems_ list = let start = scrollTopIndex list stop = scrollTopIndex list + scrollWindowSize list adjustedStop = (min stop $ length $ listItems list) - 1 diff --git a/src/Graphics/Vty/Widgets/Padding.hs b/src/Graphics/Vty/Widgets/Padding.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Padding.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, TypeSynonymInstances #-} +-- |This module provides a ''padding'' mechanism for adding padding to +-- a widget on one or more sides. +module Graphics.Vty.Widgets.Padding + ( Padded + , Padding + , Paddable(..) + , (+++) + , padded + , withPadding + , padNone + , padLeft + , padRight + , padTop + , padBottom + , padLeftRight + , padTopBottom + , padAll + ) +where + +import Data.Word +import Data.Monoid +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Util + +-- |The type of padding on widgets. +data Padding = Padding Int Int Int Int + deriving (Show) + +data Padded = forall a. (Show a) => Padded (Widget a) Padding + +instance Show Padded where + show (Padded _ p) = concat [ "Padded { " + , "padding = " + , show p + , ", ... }" + ] + +instance Monoid Padding where + mempty = Padding 0 0 0 0 + mappend (Padding a1 a2 a3 a4) (Padding b1 b2 b3 b4) = + Padding (a1 + b1) (a2 + b2) (a3 + b3) (a4 + b4) + +(+++) :: (Monoid a) => a -> a -> a +(+++) = mappend + +-- |The class of types to which we can add padding. +class Paddable a where + pad :: a -> Padding -> a + +instance Paddable Padding where + pad p1 p2 = p1 +++ p2 + +leftPadding :: Padding -> Word +leftPadding (Padding _ _ _ l) = toEnum l + +rightPadding :: Padding -> Word +rightPadding (Padding _ r _ _) = toEnum r + +bottomPadding :: Padding -> Word +bottomPadding (Padding _ _ b _) = toEnum b + +topPadding :: Padding -> Word +topPadding (Padding t _ _ _) = toEnum t + +-- |Padding constructor with no padding. +padNone :: Padding +padNone = Padding 0 0 0 0 + +-- |Padding constructor with left padding in columns. +padLeft :: Int -> Padding +padLeft v = Padding 0 0 0 v + +-- |Padding constructor with right padding in columns. +padRight :: Int -> Padding +padRight v = Padding 0 v 0 0 + +-- |Padding constructor with top padding in rows. +padTop :: Int -> Padding +padTop v = Padding v 0 0 0 + +-- |Padding constructor with bottom padding in rows. +padBottom :: Int -> Padding +padBottom v = Padding 0 0 v 0 + +-- |Padding constructor with padding on all sides in rows and +-- columns. +padAll :: Int -> Padding +padAll v = Padding v v v v + +-- |Padding constructor with padding on top and bottom in rows. +padTopBottom :: Int -> Padding +padTopBottom v = Padding v 0 v 0 + +-- |Padding constructor with padding on left and right in columns. +padLeftRight :: Int -> Padding +padLeftRight v = Padding 0 v 0 v + +-- |Monadic combinator to construct a 'Padded' wrapper. +withPadding :: (MonadIO m, Show a) => Padding -> Widget a -> m (Widget Padded) +withPadding = flip padded + +-- |Create a 'Padded' wrapper to add padding. +padded :: (MonadIO m, Show a) => Widget a -> Padding -> m (Widget Padded) +padded ch padding = do + wRef <- newWidget $ \w -> + w { state = Padded ch padding + + , growVertical_ = const $ growVertical ch + , growHorizontal_ = const $ growHorizontal ch + + , render_ = + \this sz ctx -> + if (region_width sz < 2) || (region_height sz < 2) + then return empty_image + else do + Padded child p <- getState this + f <- focused <~ this + + -- Compute constrained space based on padding + -- settings. + let constrained = sz `withWidth` (toEnum $ max 0 newWidth) + `withHeight` (toEnum $ max 0 newHeight) + newWidth = (fromEnum $ region_width sz) - fromEnum (leftPadding p + rightPadding p) + newHeight = (fromEnum $ region_height sz) - fromEnum (topPadding p + bottomPadding p) + attr = mergeAttrs [ if f then focusAttr ctx else overrideAttr ctx + , normalAttr ctx + ] + + -- Render child. + img <- render child constrained ctx + + -- Create padding images. + let leftImg = char_fill attr ' ' (leftPadding p) (image_height img) + rightImg = char_fill attr ' ' (rightPadding p) (image_height img) + topImg = char_fill attr ' ' (image_width img + leftPadding p + rightPadding p) + (topPadding p) + bottomImg = char_fill attr ' ' (image_width img + leftPadding p + rightPadding p) + (bottomPadding p) + + return $ topImg <-> (leftImg <|> img <|> rightImg) <-> bottomImg + + , setCurrentPosition_ = + \this pos -> do + Padded child p <- getState this + + -- Considering left and top padding, adjust position and + -- set on child. + let newPos = pos + `plusWidth` (leftPadding p) + `plusHeight` (topPadding p) + + setCurrentPosition child newPos + + } + + wRef `relayKeyEvents` ch + wRef `relayFocusEvents` ch + return wRef diff --git a/src/Graphics/Vty/Widgets/ProgressBar.hs b/src/Graphics/Vty/Widgets/ProgressBar.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/ProgressBar.hs @@ -0,0 +1,70 @@ +-- |This module provides a ''progress bar'' widget which stores a +-- progress value between 0 and 100 inclusive. Use the 'schedule' +-- function to modify the progress bar's state from a thread. +module Graphics.Vty.Widgets.ProgressBar + ( ProgressBar + , newProgressBar + , progressBarWidget + , setProgress + , addProgress + , getProgress + , onProgressChange + ) +where + +import Data.IORef +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Fills +import Graphics.Vty.Widgets.Box +import Graphics.Vty.Widgets.Events +import Graphics.Vty.Widgets.Util + +data ProgressBar = ProgressBar { progressBarWidget :: Widget (Box HFill HFill) + -- ^Get the widget of a progress bar. + , progressBarAmount :: IORef Int + , onChangeHandlers :: Handlers Int + } + +-- |Create a new progress bar with the specified completed and +-- uncompleted colors, respectively. +newProgressBar :: (MonadIO m) => Color -> Color -> m ProgressBar +newProgressBar completeColor incompleteColor = do + let completeAttr = completeColor `on` completeColor + incompleteAttr = incompleteColor `on` incompleteColor + + w <- (hFill ' ' 1 >>= withNormalAttribute completeAttr) <++> + (hFill ' ' 1 >>= withNormalAttribute incompleteAttr) + r <- liftIO $ newIORef 0 + hs <- newHandlers + let p = ProgressBar w r hs + setProgress p 0 + return p + +-- |Register a handler to be invoked when the progress bar's progress +-- value changes. The handler will be passed the new progress value. +onProgressChange :: (MonadIO m) => ProgressBar -> (Int -> IO ()) -> m () +onProgressChange = addHandler (return . onChangeHandlers) + +-- |Set the progress bar's progress value. Values outside the allowed +-- range will be ignored. +setProgress :: (MonadIO m) => ProgressBar -> Int -> m () +setProgress p amt = + when (amt >= 0 && amt <= 100) $ do + liftIO $ writeIORef (progressBarAmount p) amt + setBoxChildSizePolicy (progressBarWidget p) $ Percentage amt + fireEvent p (return . onChangeHandlers) amt + +-- |Get the progress bar's current progress value. +getProgress :: (MonadIO m) => ProgressBar -> m Int +getProgress = liftIO . readIORef . progressBarAmount + +-- |Add a delta value to the progress bar's current value. +addProgress :: (MonadIO m) => ProgressBar -> Int -> m () +addProgress p amt = do + cur <- getProgress p + let newAmt = cur + amt + when (newAmt >= 0 && newAmt <= 100) $ + setProgress p newAmt diff --git a/src/Graphics/Vty/Widgets/Rendering.hs b/src/Graphics/Vty/Widgets/Rendering.hs deleted file mode 100644 --- a/src/Graphics/Vty/Widgets/Rendering.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE CPP #-} --- |This module provides a basic infrastructure for modelling a user --- interface widget and converting it to Vty's 'Image' type. -module Graphics.Vty.Widgets.Rendering - ( Widget(..) - , mkImage - - -- ** Rendering process - -- |'Widget's are ultimately converted to Vty 'Image's, but this - -- library uses an intermediate type, 'Render', to represent the - -- physical layout of the images. A 'Render' represents the - -- various primitive rendering constructs which support vertical - -- and horizontal concatenation and 'Image' addressing. Once a - -- 'Widget' has been rendered (see 'render'), the resulting - -- 'Render' is then put through a /positioning pass/ in which the - -- sizes and positions of any addressable image regions are stored - -- (see 'RenderState'). The result is a single 'Image' suitable - -- for use with Vty's 'Graphics.Vty.pic_for_image' function. - , RenderState -#ifdef TESTING - , Render(..) -#else - , Render -#endif - , renderImg - , renderAddr - , renderMany - , renderWidth - , renderHeight - - -- ** Widget addressing - -- |Some widgets, such as editable widgets, require that their - -- on-screen representations be known after rendering; this - -- library supports a notion of /widget addressing/ in which a - -- 'Widget' is marked as /addressable/ (see 'addressable'). - -- Addressable widgets' position and size information ('Address') - -- will be recorded in the 'RenderState' during rendering in - -- 'mkImage'. - , Address - , address - , addressable - , addrSize - , addrPosition - , addAddress - - -- ** Miscellaneous - , Orientation(..) - , withWidth - , withHeight - -#ifdef TESTING - , mkImageSize -#endif - ) -where - -import GHC.Word ( Word ) -import qualified Data.Map as Map -import Control.Monad.State ( State, modify, runState ) - -import Graphics.Vty - ( DisplayRegion(DisplayRegion) - , Attr - , Image - , Vty(terminal) - , display_bounds - , (<|>) - , (<->) - , image_width - , image_height - , region_width - , region_height - , vert_cat - , horiz_cat - ) - --- |A simple orientation type. -data Orientation = Horizontal | Vertical - deriving (Eq, Show) - --- |The type of user interface widgets. A 'Widget' provides several --- properties: --- --- * /Growth properties/ which provide information about how to --- allocate space to widgets depending on their propensity to --- consume available space --- --- * A /primary attribute/ which is the attribute most easily --- identifiable with the widget's visual presentation --- --- * An /attribute override/ which allows the widget and its children --- to be rendered using a single attribute specified by the caller --- --- * A /rendering routine/ which converts the widget's internal state --- into a 'Render' value. --- --- Of primary concern is the rendering routine, 'render'. The --- rendering routine takes one parameter: the size of the space in --- which the widget should be rendered. The space is important --- because it provides a maximum size for the widget. For widgets --- that consume all available space, the size of the resulting --- 'Render' will be equal to the supplied size. For smaller widgets --- (e.g., a simple string of text), the size of the 'Render' will --- likely be much smaller than the supplied size. In any case, any --- 'Widget' implementation /must/ obey the rule that the resulting --- 'Render' must not exceed the supplied 'DisplayRegion' in size. If --- it does, there's a good chance your interface will be garbled. --- --- If the widget has child widgets, the supplied size should be --- subdivided to fit the child widgets as appropriate. How the space --- is subdivided may depend on the growth properties of the children --- or it may be a matter of policy. -data Widget = Widget { - -- |Render the widget with the given dimensions. The result - -- /must/ not be larger than the specified dimensions, but may be - -- smaller. - render :: DisplayRegion -> Render - - -- |Will this widget expand to take advantage of available - -- horizontal space? - , growHorizontal :: Bool - - -- |Will this widget expand to take advantage of available - -- vertical space? - , growVertical :: Bool - - -- |The primary attribute of this widget, used when composing - -- widgets. For example, if you want to compose a widget /A/ with - -- a space-filling widget /B/, you probably want /B/'s text - -- attributes to be identical to those of /A/. - , primaryAttribute :: Attr - - -- |Apply the specified attribute to this widget. - , withAttribute :: Attr -> Widget - } - --- |Information about the rendered state of a widget. -data Address = Address { addrPosition :: DisplayRegion - -- ^The rendered position of a widget. - , addrSize :: DisplayRegion - -- ^The rendered size of a widget. - } - deriving (Eq, Show) - --- |The collection of widget names (see 'addressable') and their --- rendering addresses as a result of 'render'. -type RenderState = Map.Map String Address - --- |An intermediate type used in the rendering process. Widgets are --- converted into collections of 'Image's and represented with this --- type, using a few primitive rendering instructions to determine how --- the rendered images are combined to form a complete terminal window --- image. See 'render'. -data Render = Img Image - | Addressed String Render - | Many Orientation [Render] - --- |Annotate a widget with a rendering identifier so that its --- rendering address will be stored by the rendering process. Once --- the widget has been rendered, its address will be found in the --- resulting 'RenderState'. To retrieve the address of such an --- identifier, use 'address'. -addressable :: String - -- ^The identifier of the widget to be used in the - -- 'RenderState'. - -> Widget - -- ^The widget whose rendering address ('Address') should - -- be stored. - -> Widget -addressable ident w = w { - withAttribute = addressable ident . withAttribute w - , render = renderAddr ident . render w - } - --- |Create a 'Render' containing a single 'Image'. -renderImg :: Image -> Render -renderImg = Img - --- |Create a 'Render' representing a render together with an --- identifier. This type of 'Render' is used with 'addressable' to --- locate a widget's position and dimensions in the final 'Image'. -renderAddr :: String -- ^The identifier of the widget that this - -- 'Render' represents. Should be the same - -- identifier that was passed to 'addressable'. - -> Render -- ^The 'Render' to identify. - -> Render -renderAddr = Addressed - --- |Create a 'Render' representing a collection of renders which --- should be combined in the specified 'Orientation'. -renderMany :: Orientation -> [Render] -> Render -renderMany = Many - --- |Compute the width, in columns, of a 'Render'. -renderWidth :: Render -> Word -renderWidth (Img img) = image_width img -renderWidth (Addressed _ w) = renderWidth w -renderWidth (Many Vertical ws) = maximum $ map renderWidth ws -renderWidth (Many Horizontal ws) = sum $ map renderWidth ws - --- |Compute the height, in rows, of a 'Render'. -renderHeight :: Render -> Word -renderHeight (Img img) = image_height img -renderHeight (Addressed _ w) = renderHeight w -renderHeight (Many Vertical ws) = sum $ map renderHeight ws -renderHeight (Many Horizontal ws) = maximum $ map renderHeight ws - --- |Given a starting position (usually @'DisplayRegion' 0 0@) and a --- 'Render', combine the 'Render''s contents into a single 'Image' and --- track the positions and sizes of any 'Render's with positioning --- addresses. Returns the resulting image and a 'RenderState' --- containing the 'Address' values of all addressable widgets. -doPositioning :: DisplayRegion -> Render -> State RenderState Image -doPositioning _ (Img img) = return img -doPositioning _ (Many Vertical []) = error "got empty rendered list" -doPositioning _ (Many Horizontal []) = error "got empty rendered list" - -doPositioning pos (Many Vertical widgets) = do - let positionNext _ [] = return $ vert_cat [] - positionNext p (w:ws) = do - img <- doPositioning p w - let newPos = p `withHeight` (region_height p + image_height img) - n <- positionNext newPos ws - return (img <-> n) - - positionNext pos widgets - -doPositioning pos (Many Horizontal widgets) = do - let positionNext _ [] = return $ horiz_cat [] - positionNext p (w:ws) = do - img <- doPositioning p w - let newPos = p `withWidth` (region_width p + image_width img) - n <- positionNext newPos ws - return (img <|> n) - - positionNext pos widgets - -doPositioning pos (Addressed s w) = do - img <- doPositioning pos w - addAddress s pos img - return img - --- |Retrieve the rendering address for a given widget. To annotate a --- widget to induce storage of its address, use 'addressable'. -address :: String -> RenderState -> Maybe Address -address = Map.lookup - --- |Add an address for the specified identifier, position, and 'Image' --- to the 'RenderState'. -addAddress :: String -- ^The 'Address' identifier. - -> DisplayRegion -- ^The position of the image. - -> Image -- ^The image whose size should be stored. - -> State RenderState () -addAddress ident pos img = do - let rinfo = Address pos (imageSize img) - modify (Map.insert ident rinfo) - --- |Compute the size of an 'Image' as a 'DisplayRegion'. -imageSize :: Image -> DisplayRegion -imageSize img = DisplayRegion (image_width img) (image_height img) - --- |Given a 'Widget' and a 'Vty' object, render the widget using the --- current size of the terminal controlled by Vty. Returns the --- rendered 'Widget' as an 'Image' along with the 'RenderState' --- containing the 'Address'es of 'addressable' widgets. -mkImage :: Vty -> Widget -> IO (Image, RenderState) -mkImage vty w = do - size <- display_bounds $ terminal vty - let upperLeft = DisplayRegion 0 0 - return $ mkImageSize upperLeft size w - -mkImageSize :: DisplayRegion -> DisplayRegion -> Widget - -> (Image, RenderState) -mkImageSize position size w = - let rendered = render w size - in runState (doPositioning position rendered) (Map.fromList []) - --- |Modify the width component of a 'DisplayRegion'. -withWidth :: DisplayRegion -> Word -> DisplayRegion -withWidth (DisplayRegion _ h) w = DisplayRegion w h - --- |Modify the height component of a 'DisplayRegion'. -withHeight :: DisplayRegion -> Word -> DisplayRegion -withHeight (DisplayRegion w _) h = DisplayRegion w h diff --git a/src/Graphics/Vty/Widgets/Skins.hs b/src/Graphics/Vty/Widgets/Skins.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Skins.hs @@ -0,0 +1,85 @@ +-- |This module provides ''skins'' for line-drawing widgets such as +-- borders. Different skins may be suitable for terminals with +-- different capabilities, but they are provided for greatest +-- flexibility. Unicode skins must be used with care, as not all +-- terminals support unicode characters (but most do, these days). +module Graphics.Vty.Widgets.Skins + ( Skin(..) + , asciiSkin + , unicodeSkin + , unicodeBoldSkin + , unicodeRoundedSkin + ) +where + +-- Corners start from top left and go clockwise. Intersections are: +-- full, left, right, top, bottom. +data Skin = Skin { skinCornerTL :: Char + , skinCornerTR :: Char + , skinCornerBR :: Char + , skinCornerBL :: Char + , skinIntersectionFull :: Char + , skinIntersectionL :: Char + , skinIntersectionR :: Char + , skinIntersectionT :: Char + , skinIntersectionB :: Char + , skinHorizontal :: Char + , skinVertical :: Char + } + +-- |An ASCII skin which will work in any terminal. +asciiSkin :: Skin +asciiSkin = Skin { skinCornerTL = '+' + , skinCornerTR = '+' + , skinCornerBR = '+' + , skinCornerBL = '+' + , skinIntersectionFull = '+' + , skinIntersectionL = '+' + , skinIntersectionR = '+' + , skinIntersectionT = '+' + , skinIntersectionB = '+' + , skinHorizontal = '-' + , skinVertical = '|' + } + +unicodeSkin :: Skin +unicodeSkin = Skin { skinCornerTL = '┌' + , skinCornerTR = '┐' + , skinCornerBR = '┘' + , skinCornerBL = '└' + , skinIntersectionFull = '┼' + , skinIntersectionL = '├' + , skinIntersectionR = '┤' + , skinIntersectionT = '┬' + , skinIntersectionB = '┴' + , skinHorizontal = '─' + , skinVertical = '│' + } + +unicodeBoldSkin :: Skin +unicodeBoldSkin = Skin { skinCornerTL = '┏' + , skinCornerTR = '┓' + , skinCornerBR = '┛' + , skinCornerBL = '┗' + , skinIntersectionFull = '╋' + , skinIntersectionL = '┣' + , skinIntersectionR = '┫' + , skinIntersectionT = '┳' + , skinIntersectionB = '┻' + , skinHorizontal = '━' + , skinVertical = '┃' + } + +unicodeRoundedSkin :: Skin +unicodeRoundedSkin = Skin { skinCornerTL = '╭' + , skinCornerTR = '╮' + , skinCornerBR = '╯' + , skinCornerBL = '╰' + , skinIntersectionFull = '┼' + , skinIntersectionL = '├' + , skinIntersectionR = '┤' + , skinIntersectionT = '┬' + , skinIntersectionB = '┴' + , skinHorizontal = '─' + , skinVertical = '│' + } diff --git a/src/Graphics/Vty/Widgets/Table.hs b/src/Graphics/Vty/Widgets/Table.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Table.hs @@ -0,0 +1,594 @@ +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, + TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-} +-- |This module provides a table layout widget capable of laying out +-- columns of widgets with various padding and alignment properties. +-- For complete details, please see the Vty-ui User's Manual. +module Graphics.Vty.Widgets.Table + ( Table + , TableCell + , ColumnSize(..) + , BorderStyle(..) + , BorderFlag(..) + , RowLike + , TableError(..) + , ColumnSpec + , Alignment(..) + , Alignable(..) + , (.|.) + , newTable + , setDefaultCellAlignment + , setDefaultCellPadding + , addRow + , addHeadingRow + , addHeadingRow_ + , column + , customCell + , emptyCell + ) +where + +import Data.Typeable +import Data.Word +import Data.List +import Control.Applicative hiding ((<|>)) +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Graphics.Vty +import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Text +import Graphics.Vty.Widgets.Centering +import Graphics.Vty.Widgets.Padding +import Graphics.Vty.Widgets.Borders +import Graphics.Vty.Widgets.Skins +import Graphics.Vty.Widgets.Util +import Graphics.Vty.Widgets.Fills +import Graphics.Vty.Widgets.Box + +data TableError = ColumnCountMismatch + -- ^A row added to the table did not have the same + -- number of widgets as the table has columns. + | CellImageTooBig + -- ^The image rendered by a cell widget exceeded the + -- size permitted by the cell. + | BadTableWidgetSizePolicy Int + -- ^A table cell contains a widget which grows + -- vertically, which is not permitted. + deriving (Show, Typeable) + +instance Exception TableError + +-- |Column alignment values. +data Alignment = AlignCenter | AlignLeft | AlignRight + deriving (Show) + +-- |The class of types whose values can be aligned. +class Alignable a where + align :: a -> Alignment -> a + +-- |The wrapper type for all table cells; stores the widgets +-- themselves in addition to alignment and padding settings. +-- Alignment and padding settings on a cell override the column- and +-- table-wide defaults. +data TableCell = forall a. (Show a) => TableCell (Widget a) (Maybe Alignment) (Maybe Padding) + | EmptyCell + +instance Show TableCell where + show EmptyCell = "EmptyCell" + show (TableCell _ mAl mPad) = concat [ "TableCell { " + , "alignment = " + , show mAl + , ", padding = " + , show mPad + , ", ... " + , "}" + ] + +data TableRow = TableRow [TableCell] + +-- |The types of borders we can have in a table. +data BorderFlag = Rows + -- ^Borders between rows. + | Columns + -- ^Borders between columns. + | Edges + -- ^Borders around the outside edges of the table. + deriving (Eq, Show) + +-- |The border configuration of a table. +data BorderStyle = BorderPartial [BorderFlag] + -- |A partial set of border flags. + | BorderFull + -- |Draw borders everywhere we support them. + | BorderNone + -- ^Don't draw any borders anywhere. + deriving (Eq, Show) + +-- |The type of column size policies. +data ColumnSize = ColFixed Int + -- ^The column has the specified fixed width in + -- columns. + | ColAuto + -- ^The column's width is a function of space + -- available to the table at rendering time. + deriving (Eq, Show) + +-- |The specification of a column's settings. The alignment and +-- padding of a column specification override the table-wide default. +data ColumnSpec = ColumnSpec { columnSize :: ColumnSize + , columnAlignment :: Maybe Alignment + , columnPadding :: Maybe Padding + } + deriving (Show) + +instance Paddable ColumnSpec where + pad c p = c { columnPadding = Just p } + +instance Alignable ColumnSpec where + align c a = c { columnAlignment = Just a } + +instance Paddable TableCell where + pad (TableCell w a _) p = TableCell w a (Just p) + pad EmptyCell _ = EmptyCell + +instance Alignable TableCell where + align (TableCell w _ p) a = TableCell w (Just a) p + align EmptyCell _ = EmptyCell + +-- |The class of types whose values can be used to construct table +-- rows. +class RowLike a where + mkRow :: a -> TableRow + +instance RowLike TableRow where + mkRow = id + +instance RowLike TableCell where + mkRow c = TableRow [c] + +instance (Show a) => RowLike (Widget a) where + mkRow w = TableRow [TableCell w Nothing Nothing] + +instance (RowLike a) => RowLike [a] where + mkRow rs = TableRow cs + where + cs = concat $ map (\(TableRow cells) -> cells) rs' + rs' = map mkRow rs + +-- |Row constructor using 'RowLike' instances. +(.|.) :: (RowLike a, RowLike b) => a -> b -> TableRow +(.|.) a b = TableRow (cs ++ ds) + where + (TableRow cs) = mkRow a + (TableRow ds) = mkRow b + +infixl 2 .|. + +data Table = Table { rows :: [TableRow] + , numColumns :: Int + , columnSpecs :: [ColumnSpec] + , borderStyle :: BorderStyle + , borderAttr :: Attr + , defaultCellAlignment :: Alignment + , defaultCellPadding :: Padding + } + +instance HasBorderAttr (Widget Table) where + setBorderAttribute t a = + updateWidgetState t $ \s -> s { borderAttr = mergeAttr a $ borderAttr s } + +instance Show Table where + show t = concat [ "Table { " + , "rows = <", show $ length $ rows t, " rows>" + , ", numColumns = ", show $ numColumns t + , ", columnSpecs = ", show $ columnSpecs t + , ", borderStyle = ", show $ borderStyle t + , ", borderAttr = ", show $ borderAttr t + , ", defaultCellAlignment = ", show $ defaultCellAlignment t + , ", defaultCellPadding = ", show $ defaultCellPadding t + , " }" + ] + +-- |Create a custom 'TableCell' to set its alignment and/or padding +-- settings. +customCell :: (Show a) => Widget a -> TableCell +customCell w = TableCell w Nothing Nothing + +-- |Create an empty table cell. +emptyCell :: TableCell +emptyCell = EmptyCell + +-- |Set the default table-wide cell alignment. +setDefaultCellAlignment :: (MonadIO m) => Widget Table -> Alignment -> m () +setDefaultCellAlignment t a = updateWidgetState t $ \s -> s { defaultCellAlignment = a } + +-- |Set the default table-wide cell padding. +setDefaultCellPadding :: (MonadIO m) => Widget Table -> Padding -> m () +setDefaultCellPadding t p = updateWidgetState t $ \s -> s { defaultCellPadding = p } + +-- |Create a column. +column :: ColumnSize -> ColumnSpec +column sz = ColumnSpec sz Nothing Nothing + +-- |Create a table widget using a list of column specifications and a +-- border style. +newTable :: (MonadIO m) => + [ColumnSpec] + -> BorderStyle + -> m (Widget Table) +newTable specs borderSty = do + t <- newWidget $ \w -> + w { state = Table { rows = [] + , columnSpecs = specs + , borderStyle = borderSty + , numColumns = length specs + , borderAttr = def_attr + , defaultCellAlignment = AlignLeft + , defaultCellPadding = padNone + } + + , growHorizontal_ = \st -> do + return $ any (== ColAuto) (map columnSize $ columnSpecs st) + + , render_ = + \this sz ctx -> do + rs <- rows <~~ this + let sk = skin ctx + + rowImgs <- mapM (\(TableRow r) -> renderRow this sz r ctx) rs + + rowBorder <- mkRowBorder this sz ctx $ skinIntersectionFull sk + topBorder <- mkTopBottomBorder this sz ctx $ skinIntersectionT sk + bottomBorder <- mkTopBottomBorder this sz ctx $ skinIntersectionB sk + sideBorderL <- mkSideBorder this ctx True + sideBorderR <- mkSideBorder this ctx False + + let body = vert_cat $ intersperse rowBorder rowImgs + withTBBorders = vert_cat [topBorder, body, bottomBorder] + withSideBorders = horiz_cat [sideBorderL, withTBBorders, sideBorderR] + + -- Ideally, we would only display rows that we have room + -- to render, but this is a much easier cop-out. :) + if ((region_width sz < image_width withSideBorders) || + (region_height sz < image_height withSideBorders)) then + return empty_image else + return withSideBorders + + , setCurrentPosition_ = + \this pos -> do + sz <- getCurrentSize this + if region_width sz == 0 || region_height sz == 0 then + return () else + do + bs <- borderStyle <~~ this + rs <- rows <~~ this + + let edgeOffset = if edgeBorders bs + then 1 else 0 + positionRows _ [] = return () + positionRows height ((TableRow row):rest) = + do + -- Compute the position for this row based on + -- border settings + let rowPos = pos `plusWidth` edgeOffset + `withHeight` height + + -- Get the maximum cell height + cellPhysSizes <- forM row $ \cell -> + case cell of + TableCell cw _ _ -> getCurrentSize cw + EmptyCell -> return $ DisplayRegion 0 1 + + -- Include 1 as a possible height to + -- prevent zero-height images from + -- breaking position computations. This + -- won't hurt in the case where other + -- cells are bigger, since their heights + -- will be chosen instead. + let maxSize = maximum $ 1 : map region_height cellPhysSizes + borderOffset = if rowBorders bs + then 1 else 0 + + -- Position the individual row widgets + -- (again, based on border settings) + positionRow this bs rowPos row + positionRows (height + maxSize + borderOffset) rest + + positionRows (region_height pos + edgeOffset) rs + } + return t + +getCellAlignment :: (MonadIO m) => Widget Table -> Int -> TableCell -> m Alignment +getCellAlignment _ _ (TableCell _ (Just p) _) = return p +getCellAlignment t columnNumber _ = do + -- If the column for this cell has properties, use those; otherwise + -- default to table-wide properties. + specs <- columnSpecs <~~ t + let spec = specs !! columnNumber + + case columnAlignment spec of + Nothing -> defaultCellAlignment <~~ t + Just p -> return p + +getCellPadding :: (MonadIO m) => Widget Table -> Int -> TableCell -> m Padding +getCellPadding _ _ (TableCell _ _ (Just p)) = return p +getCellPadding t columnNumber _ = do + -- If the column for this cell has properties, use those; otherwise + -- default to table-wide properties. + specs <- columnSpecs <~~ t + let spec = specs !! columnNumber + + case columnPadding spec of + Nothing -> defaultCellPadding <~~ t + Just p -> return p + +mkRowBorder :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image +mkRowBorder t sz ctx intChar = do + bs <- borderStyle <~~ t + + if not $ rowBorders bs then + return empty_image else + mkRowBorder_ t sz ctx intChar + +-- Make a row border that matches the width of each row but does not +-- include outermost edge characters. +mkRowBorder_ :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image +mkRowBorder_ t sz ctx intChar = do + bs <- borderStyle <~~ t + bAttr <- borderAttr <~~ t + specs <- columnSpecs <~~ t + aw <- autoWidth t sz + + let sk = skin ctx + bAttr' = mergeAttrs [ overrideAttr ctx + , bAttr + , normalAttr ctx + ] + szs = map columnSize specs + intersection = string bAttr' [intChar] + imgs = (flip map) szs $ \s -> + case s of + ColFixed n -> char_fill bAttr' (skinHorizontal sk) n 1 + ColAuto -> char_fill bAttr' (skinHorizontal sk) aw 1 + imgs' = if colBorders bs + then intersperse intersection imgs + else imgs + + return $ horiz_cat imgs' + +mkTopBottomBorder :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image +mkTopBottomBorder t sz ctx intChar = do + bs <- borderStyle <~~ t + + if edgeBorders bs then + mkRowBorder_ t sz ctx intChar else + return empty_image + +-- Make vertical side borders for the table, including row border +-- intersections if necessary. +mkSideBorder :: Widget Table -> RenderContext -> Bool -> IO Image +mkSideBorder t ctx isLeft = do + bs <- borderStyle <~~ t + + if edgeBorders bs then + mkSideBorder_ t ctx isLeft else + return empty_image + +mkSideBorder_ :: Widget Table -> RenderContext -> Bool -> IO Image +mkSideBorder_ t ctx isLeft = do + bs <- borderStyle <~~ t + bAttr <- borderAttr <~~ t + rs <- rows <~~ t + + let sk = skin ctx + intersection = string bAttr' [ if isLeft + then skinIntersectionL sk + else skinIntersectionR sk + ] + topCorner = string bAttr' [ if isLeft + then skinCornerTL sk + else skinCornerTR sk + ] + bottomCorner = string bAttr' [ if isLeft + then skinCornerBL sk + else skinCornerBR sk + ] + bAttr' = mergeAttrs [ overrideAttr ctx + , bAttr + , normalAttr ctx + ] + + rowHeights <- forM rs $ \(TableRow row) -> do + hs <- forM row $ \cell -> + case cell of + TableCell cw _ _ -> region_height <$> getCurrentSize cw + EmptyCell -> return 1 + return $ maximum hs + + let borderImgs = (flip map) rowHeights $ \h -> char_fill bAttr' (skinVertical sk) 1 h + withIntersections = if rowBorders bs + then intersperse intersection borderImgs + else borderImgs + + return $ vert_cat $ topCorner : withIntersections ++ [bottomCorner] + +positionRow :: Widget Table -> BorderStyle -> DisplayRegion -> [TableCell] -> IO () +positionRow t bs pos cells = do + -- Position each cell widget based on the base position of the row + -- (which starts from the origin of the leftmost widget, NOT the + -- leftmost cell border) + oldSize <- getCurrentSize t + aw <- autoWidth t oldSize + specs <- columnSpecs <~~ t + + let szs = map columnSize specs + offset = if colBorders bs + then 1 + else 0 + + cellWidth ColAuto = aw + cellWidth (ColFixed n) = toEnum n + + doPositioning _ [] = return () + doPositioning width ((szPolicy, cell):ws) = + do + case cell of + TableCell w _ _ -> setCurrentPosition w $ pos `plusWidth` width + EmptyCell -> return () + doPositioning (width + cellWidth szPolicy + offset) ws + + doPositioning 0 $ zip szs cells + +autoWidth :: (MonadIO m) => Widget Table -> DisplayRegion -> m Word +autoWidth t sz = do + specs <- columnSpecs <~~ t + bs <- borderStyle <~~ t + + let sizes = map columnSize specs + numAuto = length $ filter (== ColAuto) sizes + totalFixed = sum $ (flip map) sizes $ \s -> + case s of + ColAuto -> 0 + ColFixed n -> n + edgeWidth = if edgeBorders bs then 2 else 0 + colWidth = if colBorders bs then (toEnum $ length sizes - 1) else 0 + + return $ toEnum ((max 0 ((fromEnum $ region_width sz) - totalFixed - edgeWidth - colWidth)) + `div` numAuto) + +addHeadingRow :: (MonadIO m) => Widget Table -> Attr -> [String] -> m [Widget FormattedText] +addHeadingRow tbl attr labels = do + ws <- mapM (\s -> plainText s >>= withNormalAttribute attr) labels + addRow tbl ws + return ws + +addHeadingRow_ :: (MonadIO m) => Widget Table -> Attr -> [String] -> m () +addHeadingRow_ tbl attr labels = addHeadingRow tbl attr labels >> return () + +applyCellAlignment :: (MonadIO m) => Alignment -> TableCell -> m TableCell +applyCellAlignment _ EmptyCell = return EmptyCell +applyCellAlignment al (TableCell w a p) = do + case al of + AlignLeft -> return $ TableCell w a p + + AlignCenter -> do + -- This check really belongs in the centering code... + grow <- growHorizontal w + case grow of + False -> do + w' <- hCentered w + return $ TableCell w' a p + True -> return $ TableCell w a p + + AlignRight -> do + grow <- growHorizontal w + case grow of + False -> do + w' <- (hFill ' ' 1) <++> (return w) + return $ TableCell w' a p + True -> return $ TableCell w a p + +applyCellPadding :: (MonadIO m) => Padding -> TableCell -> m TableCell +applyCellPadding _ EmptyCell = return EmptyCell +applyCellPadding padding (TableCell w a p) = do + w' <- padded w padding + return $ TableCell w' a p + +-- |Add a row to the table. Use 'RowLike' instances to populate the +-- row. Throws 'BadTableWidgetSizePolicy' if any widgets in the row +-- grow vertically; throws 'ColumnCountMismatch' if the row's number +-- of columns does not match the table's column count. +addRow :: (MonadIO m, RowLike a) => Widget Table -> a -> m () +addRow t row = do + let (TableRow cells_) = mkRow row + + cells <- forM (zip [1..] cells_) $ \(i, c) -> do + case c of + EmptyCell -> return () + TableCell w _ _ -> do + v <- growVertical w + when (v) $ throw $ BadTableWidgetSizePolicy i + + -- Apply cell properties to the widget in this cell. + alignment <- getCellAlignment t (i - 1) c + padding <- getCellPadding t (i - 1) c + + applyCellAlignment alignment c >>= applyCellPadding padding + + nc <- numColumns <~~ t + when (length cells /= nc) $ throw ColumnCountMismatch + + updateWidgetState t $ \s -> + s { rows = rows s ++ [TableRow cells] } + +renderCell :: DisplayRegion -> TableCell -> RenderContext -> IO Image +renderCell region EmptyCell ctx = do + w <- plainText "" + render w region ctx +renderCell region (TableCell w _ _) ctx = + render w region ctx + +colBorders :: BorderStyle -> Bool +colBorders (BorderPartial fs) = Columns `elem` fs +colBorders BorderFull = True +colBorders _ = False + +edgeBorders :: BorderStyle -> Bool +edgeBorders (BorderPartial fs) = Edges `elem` fs +edgeBorders BorderFull = True +edgeBorders _ = False + +rowBorders :: BorderStyle -> Bool +rowBorders (BorderPartial fs) = Rows `elem` fs +rowBorders BorderFull = True +rowBorders _ = False + +rowHeight :: [Image] -> Word +rowHeight = maximum . map image_height + +renderRow :: Widget Table -> DisplayRegion -> [TableCell] -> RenderContext -> IO Image +renderRow tbl sz cells ctx = do + specs <- columnSpecs <~~ tbl + borderSty <- borderStyle <~~ tbl + bAttr <- borderAttr <~~ tbl + aw <- autoWidth tbl sz + + let sk = skin ctx + sizes = map columnSize specs + att = mergeAttrs [ overrideAttr ctx + , normalAttr ctx + ] + newDefault = normalAttr ctx + + cellImgs <- + forM (zip cells sizes) $ \(cellW, sizeSpec) -> + do + let cellSz = DisplayRegion cellWidth (region_height sz) + cellWidth = case sizeSpec of + ColFixed n -> toEnum n + ColAuto -> aw + + img <- renderCell cellSz cellW $ ctx { normalAttr = newDefault } + -- Right-pad the image if it isn't big enough to fill the + -- cell. + case compare (image_width img) (region_width cellSz) of + EQ -> return img + LT -> return $ img <|> char_fill att ' ' + (max 0 (region_width cellSz - image_width img)) + (max (image_height img) 1) + GT -> throw CellImageTooBig + + let maxHeight = rowHeight cellImgs + cellImgsBottomPadded = (flip map) cellImgs $ \img -> + img <-> char_fill att ' ' (image_width img) (maxHeight - image_height img) + + -- If we need to draw borders in between columns, do that. + let bAttr' = mergeAttrs [ overrideAttr ctx + , bAttr + , normalAttr ctx + ] + withBorders = case colBorders borderSty of + False -> cellImgsBottomPadded + True -> intersperse (char_fill bAttr' (skinVertical sk) 1 maxHeight) cellImgsBottomPadded + + return $ horiz_cat withBorders diff --git a/src/Graphics/Vty/Widgets/Text.hs b/src/Graphics/Vty/Widgets/Text.hs --- a/src/Graphics/Vty/Widgets/Text.hs +++ b/src/Graphics/Vty/Widgets/Text.hs @@ -1,55 +1,34 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -- |This module provides functionality for rendering 'String's as -- 'Widget's, including functionality to make structural and/or visual -- changes at rendering time. To get started, turn your ordinary --- 'String' into a 'Widget' with 'simpleText'; if you want access to --- the 'Text' for formatting purposes, use 'prepareText' followed by --- 'textWidget'. +-- 'String' into a 'Widget' with 'plainText'; if you want access to +-- the 'Text' for formatting purposes, use 'textWidget'. module Graphics.Vty.Widgets.Text - ( Text(defaultAttr, tokens) + ( Text(tokens) + , FormattedText , Formatter - -- *Text Preparation + , setText , prepareText -- *Constructing Widgets - , simpleText + , plainText , textWidget -- *Formatting , (&.&) , highlight + , nullFormatter , wrap ) where +import Control.Monad.Trans import Data.Maybe - ( isJust - ) +import Data.Word import Graphics.Vty - ( Attr - , DisplayRegion - , string - , def_attr - , horiz_cat - , region_width - , region_height - ) -import Graphics.Vty.Widgets.Rendering - ( Widget(..) - , Render - , Orientation(Vertical) - , renderMany - , renderImg - ) +import Graphics.Vty.Widgets.Core import Text.Trans.Tokenize - ( Token(..) - , tokenize - , withAnnotation - , truncLine - , wrapLine - ) import Text.Regex.PCRE.Light.Char8 - ( Regex - , match - , exec_anchored - ) +import Graphics.Vty.Widgets.Util -- |A formatter makes changes to text at rendering time. -- @@ -68,25 +47,32 @@ -- |'Text' represents a 'String' that can be manipulated with -- 'Formatter's at rendering time. -data Text = Text { defaultAttr :: Attr - -- ^The default attribute for all tokens in this text - -- object. - , tokens :: [[Token Attr]] +data Text = Text { tokens :: [[Token Attr]] -- ^The tokens of the underlying text stream. } + deriving (Show) --- |Prepare a string for rendering and assign it the specified default --- attribute. -prepareText :: Attr -> String -> Text -prepareText att s = Text { defaultAttr = att - , tokens = tokenize s att - } +data FormattedText = + FormattedText { text :: Text + , formatter :: Formatter + } --- |Construct a Widget directly from an attribute and a String. This --- is recommended if you don't need to use a 'Formatter'. -simpleText :: Attr -> String -> Widget -simpleText a s = textWidget nullFormatter $ prepareText a s +instance Show FormattedText where + show (FormattedText t _) = concat [ "FormattedText { " + , "text = ", show t + , ", formatter = ... }" + ] +-- |Prepare a string for rendering. +prepareText :: String -> Text +prepareText s = Text { tokens = tokenize s def_attr + } + +-- |Construct a Widget directly from a String. This is recommended if +-- you don't need to use a 'Formatter'. +plainText :: (MonadIO m) => String -> m (Widget FormattedText) +plainText s = textWidget nullFormatter s + -- |A formatter for wrapping text into the available space. This -- formatter will insert line breaks where appropriate so if you want -- to use other structure-sensitive formatters, run this formatter @@ -94,7 +80,8 @@ wrap :: Formatter wrap sz t = t { tokens = newTokens } where - newTokens = concatMap (wrapLine width) $ tokens t + doWrapping l = if null l then [[]] else wrapLine width l + newTokens = concatMap doWrapping $ tokens t width = fromEnum $ region_width sz -- |A highlight formatter takes a regular expression used to scan the @@ -116,35 +103,51 @@ -- |Construct a text widget formatted with the specified formatters. -- the formatters will be applied in the order given here, so be aware -- of how the formatters will modify the text (and affect each other). -textWidget :: Formatter -> Text -> Widget -textWidget formatter t = Widget { - growHorizontal = False - , growVertical = False - , primaryAttribute = defaultAttr t - , withAttribute = - \att -> textWidget formatter $ newText att - , render = renderText t formatter - } - where - newText att = t { tokens = map (map (`withAnnotation` att)) $ tokens t } +textWidget :: (MonadIO m) => Formatter -> String -> m (Widget FormattedText) +textWidget format s = do + wRef <- newWidget $ \w -> + w { state = FormattedText { text = prepareText s + , formatter = format + } + , render_ = + \this size ctx -> do + ft <- getState this + f <- focused <~ this + return $ renderText (text ft) f (formatter ft) size ctx + } + return wRef +-- |Set the text value of a 'FormattedText' widget. +setText :: (MonadIO m) => Widget FormattedText -> String -> m () +setText wRef s = do + updateWidgetState wRef $ \st -> + st { text = (prepareText s) } + -- |Low-level text-rendering routine. -renderText :: Text -> Formatter -> DisplayRegion -> Render -renderText t formatter sz = +renderText :: Text -> Bool -> Formatter -> DisplayRegion -> RenderContext -> Image +renderText t foc format sz ctx = if region_height sz == 0 - then renderImg nullImg + then nullImg else if null ls || all null ls - then renderImg nullImg - else renderMany Vertical $ take (fromEnum $ region_height sz) lineImgs + then nullImg + else vert_cat $ take (fromEnum $ region_height sz) lineImgs where -- Truncate the tokens at the specified column and split them up -- into lines - lineImgs = map (renderImg . mkLineImg) ls + attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx + , normalAttr ctx + ] + tokenAttr tok = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx + , tokenAnnotation tok + , normalAttr ctx + ] + + lineImgs = map mkLineImg ls ls = map truncateLine $ tokens newText truncateLine = truncLine (fromEnum $ region_width sz) - newText = formatter sz t + newText = format sz t mkLineImg line = if null line - then string (defaultAttr newText) " " + then char_fill attr' ' ' (region_width sz) (1::Word) else horiz_cat $ map mkTokenImg line nullImg = string def_attr "" - mkTokenImg tok = string (tokenAnnotation tok) (tokenString tok) + mkTokenImg tok = string (tokenAttr tok) (tokenString tok) diff --git a/src/Graphics/Vty/Widgets/Util.hs b/src/Graphics/Vty/Widgets/Util.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Util.hs @@ -0,0 +1,78 @@ +module Graphics.Vty.Widgets.Util + ( on + , fgColor + , bgColor + , style + , mergeAttr + , mergeAttrs + , withWidth + , withHeight + , plusWidth + , plusHeight + ) +where + +import Data.Word +import Graphics.Vty + +-- |Infix attribute constructor. Use: foregroundColor `on` +-- backgroundColor. +on :: Color -> Color -> Attr +on a b = def_attr `with_back_color` b `with_fore_color` a + +-- |Foreground-only attribute constructor. Background color and style +-- are defaulted. +fgColor :: Color -> Attr +fgColor = (def_attr `with_fore_color`) + +-- |Background-only attribute constructor. Foreground color and style +-- are defaulted. +bgColor :: Color -> Attr +bgColor = (def_attr `with_back_color`) + +-- |Style-only attribute constructor. Colors are defaulted. +style :: Style -> Attr +style = (def_attr `with_style`) + +-- Left-most attribute's fields take precedence. +-- |Merge two attributes. Leftmost attribute takes precedence where +-- it specifies any of the foreground color, background color, or +-- style. +mergeAttr :: Attr -> Attr -> Attr +mergeAttr a b = + let b1 = case attr_style a of + SetTo v -> b `with_style` v + _ -> b + b2 = case attr_fore_color a of + SetTo v -> b1 `with_fore_color` v + _ -> b1 + b3 = case attr_back_color a of + SetTo v -> b2 `with_back_color` v + _ -> b2 + in b3 + +-- |List fold version of 'mergeAttr'. +mergeAttrs :: [Attr] -> Attr +mergeAttrs attrs = foldr mergeAttr def_attr attrs + +-- |Modify the width component of a 'DisplayRegion'. +withWidth :: DisplayRegion -> Word -> DisplayRegion +withWidth (DisplayRegion _ h) w = DisplayRegion w h + +-- |Modify the height component of a 'DisplayRegion'. +withHeight :: DisplayRegion -> Word -> DisplayRegion +withHeight (DisplayRegion w _) h = DisplayRegion w h + +-- |Modify the width component of a 'DisplayRegion'. +plusWidth :: DisplayRegion -> Word -> DisplayRegion +plusWidth (DisplayRegion w' h) w = + if (fromEnum w' + fromEnum w < 0) + then error $ "plusWidth: would overflow on " ++ (show w') ++ " + " ++ (show w) + else DisplayRegion (w + w') h + +-- |Modify the height component of a 'DisplayRegion'. +plusHeight :: DisplayRegion -> Word -> DisplayRegion +plusHeight (DisplayRegion w h') h = + if (fromEnum h' + fromEnum h < 0) + then error $ "plusHeight: would overflow on " ++ (show h') ++ " + " ++ (show h) + else DisplayRegion w (h + h') diff --git a/src/ListDemo.hs b/src/ListDemo.hs new file mode 100644 --- /dev/null +++ b/src/ListDemo.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} +module Main where + +import System.Exit ( exitSuccess ) +import Graphics.Vty +import Graphics.Vty.Widgets.All + +data AppElements = + AppElements { theList :: Widget (List String FormattedText) + , theBody :: Widget FormattedText + , theFooter1 :: Widget FormattedText + , theFooter2 :: Widget FormattedText + , theEdit :: Widget Edit + , theListLimit :: Widget (VLimit (List String FormattedText)) + , uis :: Collection + } + +-- Visual attributes. +titleAttr = bright_white `on` blue +editAttr = white `on` black +focAttr = black `on` green +boxAttr = bright_yellow `on` black +bodyAttr = bright_green `on` black +selAttr = black `on` yellow +hlAttr1 = red `on` black +hlAttr2 = yellow `on` black + +uiCore appst w = do + (hBorder >>= withBorderAttribute titleAttr) + <--> w + <--> (hBorder >>= withBorderAttribute titleAttr) + <--> (return $ theEdit appst) + <--> ((return $ theFooter1 appst) + <++> (return $ theFooter2 appst) + <++> (hBorder >>= withBorderAttribute titleAttr)) + +buildUi1 appst = do + uiCore appst (return $ theList appst) + +buildUi2 appst = + uiCore appst ((return $ theListLimit appst) + <--> (hBorder >>= withBorderAttribute titleAttr) + <--> (return $ theBody appst) + <--> (vFill ' ')) + +-- Construct the application state using the message map. +mkAppElements :: IO AppElements +mkAppElements = do + lw <- newStringList selAttr [] + b <- textWidget wrap "" + f1 <- plainText "" >>= withNormalAttribute titleAttr + f2 <- plainText "[]" >>= withNormalAttribute titleAttr + e <- editWidget + ll <- vLimit 5 lw + + c <- newCollection + + return $ AppElements { theList = lw + , theBody = b + , theFooter1 = f1 + , theFooter2 = f2 + , theEdit = e + , theListLimit = ll + , uis = c + } + +updateBody :: AppElements -> Int -> IO () +updateBody st i = do + let msg = "This is the text for list entry " ++ (show $ i + 1) + setText (theBody st) msg + +updateFooterNums :: AppElements -> Widget (List a b) -> IO () +updateFooterNums st w = do + result <- getSelected w + sz <- getListSize w + let msg = case result of + Nothing -> "--/--" + Just (i, _) -> + "-" ++ (show $ i + 1) ++ "/" ++ + (show sz) ++ "-" + setText (theFooter1 st) msg + +updateFooterText :: AppElements -> Widget Edit -> String -> IO () +updateFooterText st _ t = setText (theFooter2 st) ("[" ++ t ++ "]") + +main :: IO () +main = do + st <- mkAppElements + + ui1 <- buildUi1 st + ui2 <- buildUi2 st + + fg1 <- newFocusGroup + fg2 <- newFocusGroup + + showMainUI <- addToCollection (uis st) ui1 fg1 + showMessageUI <- addToCollection (uis st) ui2 fg2 + + listCtx1 <- addToFocusGroup fg1 (theList st) + addToFocusGroup fg1 (theEdit st) + + listCtx2 <- addToFocusGroup fg2 (theList st) + addToFocusGroup fg2 (theEdit st) + + -- These event handlers will fire regardless of the input event + -- context. + (theEdit st) `onChange` (updateFooterText st (theEdit st)) + (theEdit st) `onActivate` \e -> do + addToList (theList st) =<< getEditText e + setEditText e "" + + let doBodyUpdate (SelectionOn i _ _) = updateBody st i + doBodyUpdate SelectionOff = return () + + (theList st) `onSelectionChange` doBodyUpdate + (theList st) `onSelectionChange` \_ -> updateFooterNums st $ theList st + (theList st) `onItemAdded` \_ -> updateFooterNums st $ theList st + (theList st) `onItemRemoved` \_ -> updateFooterNums st $ theList st + + (theList st) `onKeyPressed` \_ k _ -> do + case k of + (KASCII 'q') -> exitSuccess + KDel -> do + result <- getSelected (theList st) + case result of + Nothing -> return () + Just (i, _) -> removeFromList (theList st) i >> return () + return True + _ -> return False + + -- These event handlers will only fire when the UI is in the + -- appropriate mode, depending on the state of the Widget + -- Collection. + listCtx1 `onKeyPressed` \_ k _ -> do + case k of + KEnter -> do + r <- getSelected (theList st) + case r of + Nothing -> return True + Just _ -> showMessageUI >> return True + _ -> return False + + listCtx2 `onKeyPressed` \_ k _ -> do + case k of + KASCII 'c' -> showMainUI >> return True + KASCII '+' -> do + addToVLimit (theListLimit st) 1 + return True + KASCII '-' -> do + addToVLimit (theListLimit st) (-1) + return True + _ -> return False + + setEditText (theEdit st) "edit me" + + -- We need to call these handlers manually because while they will + -- be called automatically as items are added to the list in the + -- future, the items currently in the list didn't call these because + -- they weren't registered at the time the items were added. And + -- that was impossible because the list was created and populated + -- before we even got a reference to it, so we couldn't have set up + -- event handlers. + updateFooterNums st (theList st) + + -- Enter the event loop. + runUi (uis st) $ defaultContext { normalAttr = bodyAttr + , focusAttr = focAttr + } diff --git a/src/PhoneInputDemo.hs b/src/PhoneInputDemo.hs new file mode 100644 --- /dev/null +++ b/src/PhoneInputDemo.hs @@ -0,0 +1,83 @@ +module Main where + +-- This demo is discussed in the vty-ui user's manual. + +import Control.Monad +import Control.Monad.Trans + +import Graphics.Vty +import Graphics.Vty.Widgets.All + +data PhoneNumber = PhoneNumber String String String + deriving (Show) + +-- This type isn't pretty, but we have to specify the type of the +-- complete interface. Initially you can let the compiler tell you +-- what it is. +type T = Box (Box + (Box (Box (HFixed Edit) FormattedText) (HFixed Edit)) + FormattedText) (HFixed Edit) + +data PhoneInput = + PhoneInput { phoneInputWidget :: Widget T + , edit1 :: Widget Edit + , edit2 :: Widget Edit + , edit3 :: Widget Edit + , activateHandlers :: Handlers PhoneNumber + } + +newPhoneInput :: (MonadIO m) => m (PhoneInput, Widget FocusGroup) +newPhoneInput = do + ahs <- newHandlers + e1 <- editWidget + e2 <- editWidget + e3 <- editWidget + ui <- (hFixed 4 e1) <++> + (plainText "-") <++> + (hFixed 4 e2) <++> + (plainText "-") <++> + (hFixed 5 e3) + + setEditMaxLength e1 3 + setEditMaxLength e2 3 + setEditMaxLength e3 4 + + let w = PhoneInput ui e1 e2 e3 ahs + doFireEvent = const $ do + num <- mkPhoneNumber + fireEvent w (return . activateHandlers) num + + mkPhoneNumber = do + s1 <- getEditText e1 + s2 <- getEditText e2 + s3 <- getEditText e3 + return $ PhoneNumber s1 s2 s3 + + e1 `onActivate` doFireEvent + e2 `onActivate` doFireEvent + e3 `onActivate` doFireEvent + + e1 `onChange` \s -> when (length s == 3) $ focus e2 + e2 `onChange` \s -> when (length s == 3) $ focus e3 + + fg <- newFocusGroup + mapM_ (addToFocusGroup fg) [e1, e2, e3] + return (w, fg) + +onPhoneInputActivate :: (MonadIO m) => PhoneInput + -> (PhoneNumber -> IO ()) -> m () +onPhoneInputActivate input handler = + addHandler (return . activateHandlers) input handler + +main :: IO () +main = do + (p, fg) <- newPhoneInput + p `onPhoneInputActivate` (error . show) + + ui <- padded (phoneInputWidget p) (padLeftRight 5 `pad` padTopBottom 2) + + c <- newCollection + _ <- addToCollection c ui fg + + runUi c $ defaultContext { focusAttr = white `on` blue + } diff --git a/src/Text/Trans/Tokenize.hs b/src/Text/Trans/Tokenize.hs --- a/src/Text/Trans/Tokenize.hs +++ b/src/Text/Trans/Tokenize.hs @@ -39,8 +39,12 @@ | Token { tokenString :: String , tokenAnnotation :: a } - deriving (Show, Eq) + deriving (Eq) +instance (Show a) => Show (Token a) where + show (Whitespace s _) = "{" ++ s ++ "}" + show (Token s _) = "<" ++ s ++ ">" + -- |General splitter function; given a list and a predicate, split the -- list into sublists wherever the predicate matches, discarding the -- matching elements. @@ -91,14 +95,26 @@ -- |Given a list of tokens, truncate the list so that its underlying -- string representation does not exceed the specified column width. --- Note that this does not truncate /within/ a token; it merely --- returns the largest sublist of tokens that has the required length. truncLine :: Int -> [Token a] -> [Token a] -truncLine width ts = take (length $ head passing) ts +truncLine width ts = + -- If we are returning all tokens, we didn't have to do any + -- truncation. But if we *did* have to truncate, return exactly + -- 'width' characters' worth of tokens by constructing a new final + -- token with the same attribute data. + if length tokens == length ts + then tokens + else tokens ++ [lastToken] where lengths = map (length . tokenString) ts cases = reverse $ inits lengths - passing = dropWhile ((> width) . sum) cases + remaining = dropWhile ((> width) . sum) cases + tokens = take (length $ head remaining) ts + truncLength = sum $ head remaining + + lastTokenBasis = ts !! (length tokens) + lastToken = lastTokenBasis { + tokenString = take (width - truncLength) (tokenString lastTokenBasis) + } -- |Given a list of tokens without Newlines, (potentially) wrap the -- list to the specified column width. diff --git a/test/TestDriver.hs b/test/TestDriver.hs --- a/test/TestDriver.hs +++ b/test/TestDriver.hs @@ -5,17 +5,17 @@ import Test.QuickCheck import Test.QuickCheck.Test -import qualified Tests.Text as Text +import qualified Tests.FormattedText as FormattedText import qualified Tests.Tokenize as Tokenize tests :: [Property] -tests = concat [ Text.tests +tests = concat [ FormattedText.tests , Tokenize.tests ] main :: IO () main = do - results <- mapM quickCheckResult tests + results <- mapM (quickCheckWithResult (stdArgs { maxSuccess = 200 })) tests if all isSuccess results then exitSuccess else exitFailure diff --git a/test/src/Tests/FormattedText.hs b/test/src/Tests/FormattedText.hs new file mode 100644 --- /dev/null +++ b/test/src/Tests/FormattedText.hs @@ -0,0 +1,55 @@ +module Tests.FormattedText where + +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import Control.Applicative + +import Graphics.Vty +import Graphics.Vty.Widgets.Text +import Graphics.Vty.Widgets.Core + +import Tests.Util + +import Tests.Instances () + +sz :: DisplayRegion +sz = DisplayRegion 100 100 + +textHeight :: Property +textHeight = + monadicIO $ forAllM textString $ \str -> do + w <- run $ plainText str + img <- run $ render w sz defaultContext + if region_height sz == 0 then + return $ image_height img == 0 else + return $ image_height img == (toEnum $ numNewlines str + 1) + +textImageSize :: Property +textImageSize = + monadicIO $ forAllM textString $ \str -> + sizeTest (plainText str) + +textSetText :: Property +textSetText = + monadicIO $ forAllM textString $ \s1 -> + forAllM textString $ \s2 -> do + w1 <- run $ plainText s1 + w2 <- run $ plainText s2 + img1 <- run $ render w1 sz defaultContext + img2 <- run $ render w2 sz defaultContext + run $ setText w2 s1 + img3 <- run $ render w2 sz defaultContext + return $ img1 == img3 && img1 /= img2 + +textString :: Gen String +textString = listOf $ oneof [ pure 'a' + , pure '\n' + , pure ' ' + ] + +tests :: [Property] +tests = [ label "text: newlines rendered correctly" textHeight + , label "text: image size" textImageSize + , label "text: setText works" textSetText + ] diff --git a/test/src/Tests/Instances.hs b/test/src/Tests/Instances.hs --- a/test/src/Tests/Instances.hs +++ b/test/src/Tests/Instances.hs @@ -3,7 +3,6 @@ import Test.QuickCheck import Control.Applicative ( (<*>), (<$>), pure ) -import Data.Word ( Word8 ) import Graphics.Vty @@ -12,9 +11,6 @@ , pure KeepCurrent , SetTo <$> arbitrary ] - -instance Arbitrary Word8 where - arbitrary = toEnum <$> choose (0, 255) instance Arbitrary Color where arbitrary = oneof [ ISOColor <$> arbitrary diff --git a/test/src/Tests/Text.hs b/test/src/Tests/Text.hs deleted file mode 100644 --- a/test/src/Tests/Text.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Tests.Text where - -import Test.QuickCheck -import Data.Char ( isPrint ) - -import Graphics.Vty -import Graphics.Vty.Widgets.Text - -import Tests.Util -import Tests.Instances () - -textSize :: Property -textSize = - property $ forAll textString $ \str attr sz -> - let img = toImage sz $ simpleText attr str - in - if null str || region_height sz == 0 || region_width sz == 0 - then image_height img == 0 && image_width img == 0 - else image_width img <= (toEnum $ length str) && image_height img <= 1 - -textString :: Gen String -textString = listOf (arbitrary `suchThat` (\c -> isPrint c && c /= '\n')) - -tests :: [Property] -tests = [ label "textSize" textSize - , label "imageSize" $ property $ forAll textString $ - \str attr -> imageSize (simpleText attr str) - ] diff --git a/test/src/Tests/Tokenize.hs b/test/src/Tests/Tokenize.hs --- a/test/src/Tests/Tokenize.hs +++ b/test/src/Tests/Tokenize.hs @@ -7,6 +7,8 @@ import Text.Trans.Tokenize +import Tests.Util + instance (Arbitrary a) => Arbitrary (Token a) where arbitrary = oneof [ Whitespace <$> ws <*> arbitrary , Token <$> s <*> arbitrary @@ -28,29 +30,30 @@ checkToken (Whitespace s _) = all (`elem` " \t") s checkToken (Token s _) = all (not . (`elem` " \t")) s -count :: (a -> Bool) -> [a] -> Int -count _ [] = 0 -count f (a:as) = count f as + if f a then 1 else 0 - -numNewlines :: String -> Int -numNewlines = count (== '\n') +collapse :: [Token a] -> String +collapse = concat . map tokenString tests :: [Property] -tests = [ label "tokenizeConsistency" $ property $ forAll tokenGen $ +tests = [ label "tokenize: round trip test" $ property $ forAll tokenGen $ \ts -> serialize ts == (serialize $ tokenize (serialize ts) ()) - , label "tokenizeContents" $ property $ forAll stringGen $ + + , label "tokenize: token contents consistent with constructors" $ + property $ forAll stringGen $ \s -> all (all checkToken) $ tokenize s undefined - , label "tokenizeNewlines" $ property $ forAll stringGen $ + + , label "tokenize: newlines handled properly" $ property $ forAll stringGen $ \s -> numNewlines s + 1 == (length $ tokenize s undefined) - , label "truncLine" $ property $ forAll lineGen $ + + , label "tokenize: line truncation works" $ property $ forAll lineGen $ \ts -> forAll (arbitrary :: Gen (Positive Int)) $ - \width -> length (truncLine (fromIntegral width) ts) <= - (fromIntegral width) + \width -> let l = truncLine (fromIntegral width) ts + in length (collapse l) <= fromIntegral width + -- wrapping: a single line wrapped should always result in -- lines that are no greater than the wrapping width, unless -- they have a single token. - , label "wrapLine" $ property $ forAll lineGen $ - \ts -> forAll (choose (0, length ts + 1)) $ + , label "tokenize: line-wrapping works" $ property $ forAll lineGen $ + \ts -> forAll (choose (0, length ts + 10)) $ \width -> let ls = wrapLine w ts w = fromIntegral width f l = length (serialize [l]) <= w || length l == 1 diff --git a/test/src/Tests/Util.hs b/test/src/Tests/Util.hs --- a/test/src/Tests/Util.hs +++ b/test/src/Tests/Util.hs @@ -1,14 +1,28 @@ module Tests.Util where import Graphics.Vty -import Graphics.Vty.Widgets.Rendering - -toImage :: DisplayRegion -> Widget -> Image -toImage sz w = fst $ mkImageSize upperLeft sz w - where upperLeft = DisplayRegion 0 0 +import Graphics.Vty.Widgets.Core +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Tests.Instances () -imageSize :: Widget -> DisplayRegion -> Bool -imageSize w sz = +imageSize :: Image -> DisplayRegion -> Bool +imageSize img sz = image_width img <= region_width sz && image_height img <= region_height sz - where - img = toImage sz w + +count :: (a -> Bool) -> [a] -> Int +count _ [] = 0 +count f (a:as) = count f as + if f a then 1 else 0 + +numNewlines :: String -> Int +numNewlines = count (== '\n') + +sizeTest :: (Show a) => IO (Widget a) -> PropertyM IO Bool +sizeTest mkWidget = + forAllM arbitrary $ \sz -> do + w <- run mkWidget + img <- run $ render w sz defaultContext + if region_height sz == 0 || region_width sz == 0 then + return $ image_height img == 0 && image_width img == 0 else + return $ image_width img <= region_width sz && + image_height img <= region_height sz diff --git a/vty-ui.cabal b/vty-ui.cabal --- a/vty-ui.cabal +++ b/vty-ui.cabal @@ -1,50 +1,119 @@ Name: vty-ui -Version: 0.4 -Synopsis: A user interface composition library for Vty +Version: 1.0 +Synopsis: An interactive terminal user interface library + for Vty Description: An extensible library of user interface widgets for composing and laying out Vty user interfaces. - This library provides a collection of primitives - for building and composing widgets and creating - Vty Images. This library is intended to make - non-trivial user interfaces trivial to express - and modify without having to worry about terminal - size. + This library provides a collection of widgets for + building and composing interactive interactive, + event-driven terminal interfaces. This library + is intended to make non-trivial user interfaces + easy to express and modify without having to + worry about terminal size. Category: User Interfaces -Author: Jonathan Daugherty -Maintainer: Jonathan Daugherty +Author: Jonathan Daugherty +Maintainer: Jonathan Daugherty Build-Type: Simple License: BSD3 License-File: LICENSE Cabal-Version: >= 1.2 Homepage: http://codevine.org/vty-ui/ +Data-Files: + doc/ch1/api_notes.tex + doc/ch1/getting_started.tex + doc/ch1/main.tex + doc/ch2/main.tex + doc/ch2/collections.tex + doc/ch2/composing.tex + doc/ch2/event_loop.tex + doc/ch2/focus_groups.tex + doc/ch2/handling_user_input.tex + doc/ch3/cursor_positioning.tex + doc/ch3/deferring_to_children.tex + doc/ch3/growth_policy_functions.tex + doc/ch3/implementing_composite_widgets.tex + doc/ch3/implementing_event_handlers.tex + doc/ch3/main.tex + doc/ch3/new_widget_type.tex + doc/ch3/rendering.tex + doc/ch3/widget_positioning.tex + doc/ch3/widgetimpl_api.tex + doc/ch4/Borders.tex + doc/ch4/Box.tex + doc/ch4/Button.tex + doc/ch4/Centering.tex + doc/ch4/CheckBox.tex + doc/ch4/Collection.tex + doc/ch4/Dialog.tex + doc/ch4/DirBrowser.tex + doc/ch4/Edit.tex + doc/ch4/Fills.tex + doc/ch4/Fixed.tex + doc/ch4/FormattedText.tex + doc/ch4/main.tex + doc/ch4/Limits.tex + doc/ch4/List.tex + doc/ch4/Padded.tex + doc/ch4/ProgressBar.tex + doc/ch4/Table.tex + doc/macros.tex + doc/Makefile + doc/vty-ui-users-manual.tex + doc/title_page.tex + doc/toc.tex + Flag testing Description: Build for testing Default: False +Flag demos + Description: Build demonstration programs + Default: False + Library Build-Depends: base >= 4 && < 5, - vty >= 4.0 && < 4.5, + vty >= 4.6 && < 4.7, containers >= 0.2 && < 0.4, - pcre-light >= 0.3 && < 0.4 + pcre-light >= 0.3 && < 0.4, + directory >= 1.0 && < 1.1, + filepath >= 1.1 && < 1.2, + unix >= 2.4 && < 2.5, + mtl >= 2.0 && < 2.1 GHC-Options: -Wall + Hs-Source-Dirs: src Exposed-Modules: Graphics.Vty.Widgets.All Graphics.Vty.Widgets.Text - Graphics.Vty.Widgets.Rendering - Graphics.Vty.Widgets.Composed - Graphics.Vty.Widgets.Base + Graphics.Vty.Widgets.Core + Graphics.Vty.Widgets.Box Graphics.Vty.Widgets.List Graphics.Vty.Widgets.Borders + Graphics.Vty.Widgets.EventLoop + Graphics.Vty.Widgets.Edit + Graphics.Vty.Widgets.Util + Graphics.Vty.Widgets.Table + Graphics.Vty.Widgets.CheckBox + Graphics.Vty.Widgets.Padding + Graphics.Vty.Widgets.Limits + Graphics.Vty.Widgets.Fixed + Graphics.Vty.Widgets.Fills + Graphics.Vty.Widgets.Centering + Graphics.Vty.Widgets.Skins + Graphics.Vty.Widgets.Events + Graphics.Vty.Widgets.Dialog + Graphics.Vty.Widgets.Button + Graphics.Vty.Widgets.ProgressBar + Graphics.Vty.Widgets.DirBrowser Other-Modules: Text.Trans.Tokenize Executable vty-ui-tests Build-Depends: - QuickCheck >= 2.1 && < 2.2 + QuickCheck >= 2.4 && < 2.5 CPP-Options: -DTESTING GHC-Options: -Wall @@ -54,16 +123,80 @@ end Hs-Source-Dirs: src,test,test/src Main-is: TestDriver.hs + if os(darwin) + Extra-Lib-Dirs: /usr/lib Other-Modules: Tests.Instances Tests.Util - Tests.Text + Tests.FormattedText Tests.Tokenize -Executable vty-ui-demo +Executable vty-ui-list-demo Hs-Source-Dirs: src GHC-Options: -Wall - Main-is: Demo.hs + Main-is: ListDemo.hs + if os(darwin) + Extra-Lib-Dirs: /usr/lib Build-Depends: - mtl >= 1.1 && < 1.2 + base >= 4 && < 5, + mtl >= 2.0 && < 2.1, + vty >= 4.6 && < 4.7 + if !flag(demos) + Buildable: False + +Executable vty-ui-complex-demo + Hs-Source-Dirs: src + GHC-Options: -Wall + Main-is: ComplexDemo.hs + if os(darwin) + Extra-Lib-Dirs: /usr/lib + Build-Depends: + base >= 4 && < 5, + mtl >= 2.0 && < 2.1, + bytestring >= 0.9 && < 1.0, + time >= 1.1 && < 1.2, + old-locale >= 1.0 && < 1.1, + pcre-light >= 0.3 && < 0.4, + vty >= 4.6 && < 4.7 + if !flag(demos) + Buildable: False + +Executable vty-ui-dirbrowser-demo + Hs-Source-Dirs: src + GHC-Options: -Wall + Main-is: DirBrowserDemo.hs + if os(darwin) + Extra-Lib-Dirs: /usr/lib + Build-Depends: + base >= 4 && < 5, + mtl >= 2.0 && < 2.1, + vty >= 4.6 && < 4.7 + if !flag(demos) + Buildable: False + +Executable vty-ui-phoneinput-demo + Hs-Source-Dirs: src + GHC-Options: -Wall + Main-is: PhoneInputDemo.hs + if os(darwin) + Extra-Lib-Dirs: /usr/lib + Build-Depends: + base >= 4 && < 5, + mtl >= 2.0 && < 2.1, + vty >= 4.6 && < 4.7 + if !flag(demos) + Buildable: False + +Executable vty-ui-dialog-demo + Hs-Source-Dirs: src + GHC-Options: -Wall + Main-is: DialogDemo.hs + if os(darwin) + Extra-Lib-Dirs: /usr/lib + Build-Depends: + base >= 4 && < 5, + mtl >= 2.0 && < 2.1, + vty >= 4.6 && < 4.7 + if !flag(demos) + Buildable: False