packages feed

vty-ui 0.4 → 1.0

raw patch · 82 files changed

+8135/−1067 lines, 82 filesdep +bytestringdep +directorydep +filepathdep ~QuickCheckdep ~mtldep ~vtynew-component:exe:vty-ui-complex-demonew-component:exe:vty-ui-dialog-demonew-component:exe:vty-ui-dirbrowser-demonew-component:exe:vty-ui-list-demonew-component:exe:vty-ui-phoneinput-demo

Dependencies added: bytestring, directory, filepath, old-locale, time, unix

Dependency ranges changed: QuickCheck, mtl, vty

Files

LICENSE view
@@ -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
+ doc/Makefile view
@@ -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]/*~
+ doc/ch1/api_notes.tex view
@@ -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.
+ doc/ch1/getting_started.tex view
@@ -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}
+ doc/ch1/main.tex view
@@ -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}
+ doc/ch2/collections.tex view
@@ -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.
+ doc/ch2/composing.tex view
@@ -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}.
+ doc/ch2/event_loop.tex view
@@ -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}
+ doc/ch2/focus_groups.tex view
@@ -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.
+ doc/ch2/handling_user_input.tex view
@@ -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."
+ doc/ch2/main.tex view
@@ -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}
+ doc/ch3/cursor_positioning.tex view
@@ -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.
+ doc/ch3/deferring_to_children.tex view
@@ -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.
+ doc/ch3/growth_policy_functions.tex view
@@ -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}.
+ doc/ch3/implementing_composite_widgets.tex view
@@ -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}.
+ doc/ch3/implementing_event_handlers.tex view
@@ -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~}.
+ doc/ch3/main.tex view
@@ -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}
+ doc/ch3/new_widget_type.tex view
@@ -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.
+ doc/ch3/rendering.tex view
@@ -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.
+ doc/ch3/widget_positioning.tex view
@@ -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.
+ doc/ch3/widgetimpl_api.tex view
@@ -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.
+ doc/ch4/Borders.tex view
@@ -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.
+ doc/ch4/Box.tex view
@@ -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}
+ doc/ch4/Button.tex view
@@ -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.
+ doc/ch4/Centering.tex view
@@ -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.
+ doc/ch4/CheckBox.tex view
@@ -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.
+ doc/ch4/Collection.tex view
@@ -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.
+ doc/ch4/Dialog.tex view
@@ -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.
+ doc/ch4/DirBrowser.tex view
@@ -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.
+ doc/ch4/Edit.tex view
@@ -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.
+ doc/ch4/Fills.tex view
@@ -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.
+ doc/ch4/Fixed.tex view
@@ -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.
+ doc/ch4/FormattedText.tex view
@@ -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.
+ doc/ch4/Limits.tex view
@@ -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.
+ doc/ch4/List.tex view
@@ -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.
+ doc/ch4/Padded.tex view
@@ -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.
+ doc/ch4/ProgressBar.tex view
@@ -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.
+ doc/ch4/Table.tex view
@@ -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.
+ doc/ch4/main.tex view
@@ -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}
+ doc/macros.tex view
@@ -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}
+ doc/title_page.tex view
@@ -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
+ doc/toc.tex view
@@ -0,0 +1,2 @@+\tableofcontents+\newpage
+ doc/vty-ui-users-manual.tex view
@@ -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}
+ src/ComplexDemo.hs view
@@ -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 = "- <TAB> switches input elements\n\n\+            \- ordinary keystrokes edit\n\n\+            \- <SPC> toggles radio buttons and checkboxes\n\n\+            \- <ESC> 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+                           }
− src/Demo.hs 
@@ -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
+ src/DialogDemo.hs view
@@ -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 "<enter text>"+  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 }
+ src/DirBrowserDemo.hs view
@@ -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+                           }
src/Graphics/Vty/Widgets/All.hs view
@@ -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
− src/Graphics/Vty/Widgets/Base.hs 
@@ -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
src/Graphics/Vty/Widgets/Borders.hs view
@@ -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]
+ src/Graphics/Vty/Widgets/Box.hs view
@@ -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)
+ src/Graphics/Vty/Widgets/Button.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Centering.hs view
@@ -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')
+ src/Graphics/Vty/Widgets/CheckBox.hs view
@@ -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 }
− src/Graphics/Vty/Widgets/Composed.hs 
@@ -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
+ src/Graphics/Vty/Widgets/Core.hs view
@@ -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 }
+ src/Graphics/Vty/Widgets/Dialog.hs view
@@ -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
+ src/Graphics/Vty/Widgets/DirBrowser.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Edit.hs view
@@ -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)
+ src/Graphics/Vty/Widgets/EventLoop.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Events.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Fills.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Fixed.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Limits.hs view
@@ -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
src/Graphics/Vty/Widgets/List.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Padding.hs view
@@ -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
+ src/Graphics/Vty/Widgets/ProgressBar.hs view
@@ -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
− src/Graphics/Vty/Widgets/Rendering.hs 
@@ -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
+ src/Graphics/Vty/Widgets/Skins.hs view
@@ -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 = '│'+                          }
+ src/Graphics/Vty/Widgets/Table.hs view
@@ -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
src/Graphics/Vty/Widgets/Text.hs view
@@ -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)
+ src/Graphics/Vty/Widgets/Util.hs view
@@ -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')
+ src/ListDemo.hs view
@@ -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+                                  }
+ src/PhoneInputDemo.hs view
@@ -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+                           }
src/Text/Trans/Tokenize.hs view
@@ -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.
test/TestDriver.hs view
@@ -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
+ test/src/Tests/FormattedText.hs view
@@ -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+        ]
test/src/Tests/Instances.hs view
@@ -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
− test/src/Tests/Text.hs 
@@ -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)-        ]
test/src/Tests/Tokenize.hs view
@@ -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
test/src/Tests/Util.hs view
@@ -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
vty-ui.cabal view
@@ -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 <drcygnus@gmail.com>-Maintainer:          Jonathan Daugherty <drcygnus@gmail.com>+Author:              Jonathan Daugherty <jtd@galois.com>+Maintainer:          Jonathan Daugherty <jtd@galois.com> 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