diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/doc/ch4/FormattedText.tex b/doc/ch4/FormattedText.tex --- a/doc/ch4/FormattedText.tex +++ b/doc/ch4/FormattedText.tex @@ -69,6 +69,13 @@ t <- textWidget wrap "foobar" \end{haskellcode} +In addition, the formatter for a text widget can be set at any time +with \fw{setTextFormatter}: + +\begin{haskellcode} + setTextFormatter t wrap +\end{haskellcode} + When a text widget's contents are updated, the text is automatically broken up into tokens (see Section \ref{sec:updatingText}). It is these tokens on which formatters operate. diff --git a/doc/ch4/Groups.tex b/doc/ch4/Groups.tex new file mode 100644 --- /dev/null +++ b/doc/ch4/Groups.tex @@ -0,0 +1,42 @@ +\section{Groups} +\label{sec:groups} + +The \fw{Group} module provides a widget for containing a group of +widgets of the same type, together with a pointer to the ``current'' +widget for the group. This can be used to embed a collection of +widgets in the interface while being able to change which of the +widgets is being displayed. This prevents users from having to +construct new interfaces around each new widget, and the group can be +modified at runtime. + +To create a group, use the \fw{newGroup} function: + +\begin{haskellcode} + g <- newGroup +\end{haskellcode} + +A group contains one or more widgets of any type, although they must +all have the same type within the group. To add widgets to a group, +use \fw{addToGroup}: + +\begin{haskellcode} + switchToT1 <- addToGroup g =<< plainText "first" + switchToT2 <- addToGroup g =<< plainText "second" +\end{haskellcode} + +The \fw{addToGroup} function returns an \fw{IO} action. This action, +when evaluated, will change the group's currently-active widget to the +one passed to \fw{addToGroup}. In the above example, evaluating +\fw{switchToT2} would cause group \fw{g} to show the text widget +containing \fw{"second"}. + +\subsubsection{Input and Focus Events} + +Group widgets relay all key events received to the currently-active +widget in the group, if any. Focus events on the group propagate to +the currently-active widget. + +\subsubsection{Growth Policy} + +Group widgets act as wrappers for the widgets they contain, so they +delegate all growth policy settings from the widgets being wrapped. diff --git a/doc/ch4/main.tex b/doc/ch4/main.tex --- a/doc/ch4/main.tex +++ b/doc/ch4/main.tex @@ -15,17 +15,18 @@ \input{ch4/Borders} \input{ch4/Box} \input{ch4/Button} +\input{ch4/Centering} \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/Groups} \input{ch4/Limits} \input{ch4/List} \input{ch4/Padded} \input{ch4/ProgressBar} \input{ch4/Table} +\input{ch4/FormattedText} diff --git a/doc/macros.tex b/doc/macros.tex --- a/doc/macros.tex +++ b/doc/macros.tex @@ -1,6 +1,6 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.2} +\newcommand{\vtyuiversion}{1.3} \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}} diff --git a/doc/minted.sty b/doc/minted.sty new file mode 100644 --- /dev/null +++ b/doc/minted.sty @@ -0,0 +1,227 @@ +%% +%% This is file `minted.sty', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% minted.dtx (with options: `package') +%% Copyright 2010 Konrad Rudolph +%% +%% This work may be distributed and/or modified under the +%% conditions of the LaTeX Project Public License, either version 1.3 +%% of this license or (at your option) any later version. +%% The latest version of this license is in +%% http://www.latex-project.org/lppl.txt +%% and version 1.3 or later is part of all distributions of LaTeX +%% version 2005/12/01 or later. +%% +%% Additionally, the project may be distributed under the terms of the new BSD +%% license. +%% +%% This work has the LPPL maintenance status `maintained'. +%% +%% The Current Maintainer of this work is Konrad Rudolph. +%% +%% This work consists of the files mints.dtx and mints.ins +%% and the derived file mints.sty. +\NeedsTeXFormat{LaTeX2e} +\ProvidesPackage{minted}[2010/01/27 v1.6 Yet another Pygments shim for LaTeX] +\RequirePackage{keyval} +\RequirePackage{fancyvrb} +\RequirePackage{color} +\RequirePackage{float} +\RequirePackage{ifthen} +\RequirePackage{calc} +\RequirePackage{ifplatform} +\ifwindows + \providecommand\DeleteFile[1]{\immediate\write18{del #1}} +\else + \providecommand\DeleteFile[1]{\immediate\write18{rm #1}} +\fi +\newboolean{AppExists} +\providecommand\TestAppExists[1]{ + \ifwindows + \DeleteFile{\jobname.aex} + \immediate\write18{for \string^\@percentchar i in (#1.exe #1.bat #1.cmd) + do set >\jobname.aex >\jobname.aex} %$ + \newread\@appexistsfile + \immediate\openin\@appexistsfile\jobname.aex + \expandafter\def\expandafter\@tmp@cr\expandafter{\the\endlinechar} + \endlinechar=-1\relax + \readline\@appexistsfile to \@apppathifexists + \endlinechar=\@tmp@cr + \ifthenelse{\equal{\@apppathifexists}{}} + {\AppExistsfalse} + {\AppExiststrue} + \immediate\closein\@appexistsfile + \DeleteFile{\jobname.aex} +\immediate\typeout{file deleted} + \else + \immediate\write18{which #1 && touch \jobname.aex} + \IfFileExists{\jobname.aex} + {\AppExiststrue + \DeleteFile{\jobname.aex}} + {\AppExistsfalse} + \fi} +\newcommand\minted@resetoptions{} +\newcommand\minted@defopt[1]{ + \expandafter\def\expandafter\minted@resetoptions\expandafter{% + \minted@resetoptions + \@namedef{minted@opt@#1}{}}} +\newcommand\minted@opt[1]{ + \expandafter\detokenize% + \expandafter\expandafter\expandafter{\csname minted@opt@#1\endcsname}} +\newcommand\minted@define@opt[3][]{ + \minted@defopt{#2} + \ifthenelse{\equal{#1}{}}{ + \define@key{minted@opt}{#2}{\@namedef{minted@opt@#2}{#3}}} + {\define@key{minted@opt}{#2}[#1]{\@namedef{minted@opt@#2}{#3}}}} +\newcommand\minted@define@switch[2]{ + \minted@defopt{#1} + \define@booleankey{minted@opt}{#1}{ + \@namedef{minted@opt@#1}{#2}} + {\@namedef{minted@opt@#1}{}}} +\minted@defopt{extra} +\newcommand\minted@define@extra[1]{ + \define@key{minted@opt}{#1}{ + \expandafter\def\expandafter\minted@opt@extra\expandafter{% + \minted@opt@extra,#1=##1}}} +\newcommand\minted@define@extra@switch[1]{ + \define@booleankey{minted@opt}{#1} + {\expandafter\def\expandafter\minted@opt@extra\expandafter{% + \minted@opt@extra,#1}} + {\expandafter\def\expandafter\minted@opt@extra\expandafter{% + \minted@opt@extra,#1=false}}} +\minted@define@switch{texcl}{-P texcomments} +\minted@define@switch{mathescape}{-P mathescape} +\minted@define@switch{linenos}{-P linenos} +\minted@define@opt{gobble}{-F gobble:n=#1} +\minted@define@opt{bgcolor}{#1} +\minted@define@extra{frame} +\minted@define@extra{framesep} +\minted@define@extra{framerule} +\minted@define@extra{rulecolor} +\minted@define@extra{numbersep} +\minted@define@extra{firstnumber} +\minted@define@extra{stepnumber} +\minted@define@extra{firstline} +\minted@define@extra{lastline} +\minted@define@extra{baselinestretch} +\minted@define@extra{xleftmargin} +\minted@define@extra{xrightmargin} +\minted@define@extra{fillcolor} +\minted@define@extra{tabsize} +\minted@define@extra{fontfamily} +\minted@define@extra{fontsize} +\minted@define@extra{fontshape} +\minted@define@extra{fontseries} +\minted@define@extra{formatcom} +\minted@define@extra@switch{numberblanklines} +\minted@define@extra@switch{showspaces} +\minted@define@extra@switch{resetmargins} +\minted@define@extra@switch{samepage} +\minted@define@extra@switch{showtabs} +\minted@define@extra@switch{obeytabs} +\newsavebox{\minted@bgbox} +\newenvironment{minted@colorbg}[1]{ + \def\minted@bgcol{#1} + \noindent + \begin{lrbox}{\minted@bgbox} + \begin{minipage}{\linewidth-2\fboxsep}} + {\end{minipage} + \end{lrbox}% + \colorbox{\minted@bgcol}{\usebox{\minted@bgbox}}} +\newwrite\minted@code +\newcommand\minted@savecode[1]{ + \immediate\openout\minted@code\jobname.pyg + \immediate\write\minted@code{#1} + \immediate\closeout\minted@code} +\newcommand\minted@pygmentize[2][\jobname.pyg]{ + \def\minted@cmd{pygmentize -l #2 -f latex -F tokenmerge + \minted@opt{gobble} \minted@opt{texcl} \minted@opt{mathescape} + \minted@opt{linenos} -P "verboptions=\minted@opt{extra}" + -o \jobname.out.pyg #1} + \immediate\write18{\minted@cmd} + \ifthenelse{\equal{\minted@opt@bgcolor}{}} + {} + {\begin{minted@colorbg}{\minted@opt@bgcolor}} + \input{\jobname.out.pyg} + \ifthenelse{\equal{\minted@opt@bgcolor}{}} + {} + {\end{minted@colorbg}} + \DeleteFile{\jobname.out.pyg}} +\newcommand\minted@usedefaultstyle{\usemintedstyle{default}} +\newcommand\usemintedstyle[1]{ + \renewcommand\minted@usedefaultstyle{} + \immediate\write18{pygmentize -S #1 -f latex > \jobname.pyg} + \input{\jobname.pyg}} +\newcommand\mint[3][]{ + \DefineShortVerb{#3} + \minted@resetoptions + \setkeys{minted@opt}{#1} + \SaveVerb[aftersave={ + \UndefineShortVerb{#3} + \minted@savecode{\FV@SV@minted@verb} + \minted@pygmentize{#2} + \DeleteFile{\jobname.pyg}}]{minted@verb}#3} +\newcommand\minted@proglang[1]{} +\newenvironment{minted}[2][] + {\VerbatimEnvironment + \renewcommand{\minted@proglang}[1]{#2} + \minted@resetoptions + \setkeys{minted@opt}{#1} + \begin{VerbatimOut}{\jobname.pyg}}% + {\end{VerbatimOut} + \minted@pygmentize{\minted@proglang{}} + \DeleteFile{\jobname.pyg}} +\newcommand\inputminted[3][]{ + \minted@resetoptions + \setkeys{minted@opt}{#1} + \minted@pygmentize[#3]{#2}} +\newcommand\newminted[3][]{ + \ifthenelse{\equal{#1}{}} + {\def\minted@envname{#2code}} + {\def\minted@envname{#1}} + \newenvironment{\minted@envname} + {\VerbatimEnvironment\begin{minted}[#3]{#2}} + {\end{minted}} + \newenvironment{\minted@envname *}[1] + {\VerbatimEnvironment\begin{minted}[#3,##1]{#2}} + {\end{minted}}} +\newcommand\newmint[3][]{ + \ifthenelse{\equal{#1}{}} + {\def\minted@shortname{#2}} + {\def\minted@shortname{#1}} + \expandafter\newcommand\csname\minted@shortname\endcsname[2][]{ + \mint[#3,##1]{#2}##2}} +\newcommand\newmintedfile[3][]{ + \ifthenelse{\equal{#1}{}} + {\def\minted@shortname{#2file}} + {\def\minted@shortname{#1}} + \expandafter\newcommand\csname\minted@shortname\endcsname[2][]{ + \inputminted[#3,##1]{#2}{##2}}} +\newfloat{listing}{h}{lol} +\newcommand\listingscaption{Listing} +\floatname{listing}{\listingscaption} +\newcommand\listoflistingscaption{List of listings} +\providecommand\listoflistings{\listof{listing}{\listoflistingscaption}} +\AtBeginDocument{ + \minted@usedefaultstyle} +\AtEndOfPackage{ + \ifeof18 + \PackageError{minted} + {You must invoke LaTeX with the + -shell-escape flag} + {Pass the -shell-escape flag to LaTeX. Refer to the minted.sty + documentation for more information.}\fi} + \TestAppExists{pygmentize} + \ifAppExists\else + \PackageError{minted} + {You must have `pygmentize' installed + to use this package} + {Refer to the installation instructions in the minted + documentation for more information.} + \fi +\endinput +%% +%% End of file `minted.sty'. diff --git a/src/ComplexDemo.hs b/src/ComplexDemo.hs --- a/src/ComplexDemo.hs +++ b/src/ComplexDemo.hs @@ -9,7 +9,7 @@ import Data.Time.Format import Text.Regex.PCRE import Text.Regex.PCRE.String -import Graphics.Vty +import Graphics.Vty hiding (pad) import Graphics.Vty.Widgets.All -- Visual attributes. diff --git a/src/Graphics/Vty/Widgets/All.hs b/src/Graphics/Vty/Widgets/All.hs --- a/src/Graphics/Vty/Widgets/All.hs +++ b/src/Graphics/Vty/Widgets/All.hs @@ -21,6 +21,7 @@ , module Graphics.Vty.Widgets.Button , module Graphics.Vty.Widgets.ProgressBar , module Graphics.Vty.Widgets.DirBrowser + , module Graphics.Vty.Widgets.Group ) where @@ -45,3 +46,4 @@ import Graphics.Vty.Widgets.Button import Graphics.Vty.Widgets.ProgressBar import Graphics.Vty.Widgets.DirBrowser +import Graphics.Vty.Widgets.Group diff --git a/src/Graphics/Vty/Widgets/Borders.hs b/src/Graphics/Vty/Widgets/Borders.hs --- a/src/Graphics/Vty/Widgets/Borders.hs +++ b/src/Graphics/Vty/Widgets/Borders.hs @@ -28,7 +28,7 @@ import Graphics.Vty.Widgets.Skins -- |The class of types with a border attribute, which differs from the --- |normal and focused attributes. +-- normal and focused attributes. class HasBorderAttr a where setBorderAttribute :: a -> Attr -> IO () @@ -39,19 +39,28 @@ setBorderAttribute t a = updateWidgetState t $ \(HBorder a' s) -> HBorder (mergeAttr a a') s +-- | Sets the border attribute of a thing with a border attribute. withBorderAttribute :: (HasBorderAttr a) => Attr -> a -> IO a withBorderAttribute att w = setBorderAttribute w att >> return w +-- | Adds a label to a horizontal border. The label will be +-- horizontally centered. withHBorderLabel :: String -> Widget HBorder -> IO (Widget HBorder) withHBorderLabel label w = setHBorderLabel w label >> return w +-- | Adds a label to a horizontal border. The label will be +-- horizontally centered. setHBorderLabel :: Widget HBorder -> String -> IO () setHBorderLabel w label = updateWidgetState w $ \(HBorder a _) -> HBorder a label +-- | Adds a label to the top border of a bordered widget. The label +-- will be horizontally centered. withBorderedLabel :: String -> Widget (Bordered a) -> IO (Widget (Bordered a)) withBorderedLabel label w = setBorderedLabel w label >> return w +-- | Adds a label to the top border of a bordered widget. The label +-- will be horizontally centered. setBorderedLabel :: Widget (Bordered a) -> String -> IO () setBorderedLabel w label = updateWidgetState w $ \(Bordered a ch _) -> Bordered a ch label @@ -161,7 +170,9 @@ drawBordered :: (Show a) => Bordered a -> DisplayRegion -> RenderContext -> IO Image -drawBordered this s ctx = do +drawBordered this s ctx + | region_width s < 2 || region_height s < 2 = return empty_image + | otherwise = do let Bordered attr child label = this attr' = mergeAttrs [ overrideAttr ctx , attr diff --git a/src/Graphics/Vty/Widgets/Box.hs b/src/Graphics/Vty/Widgets/Box.hs --- a/src/Graphics/Vty/Widgets/Box.hs +++ b/src/Graphics/Vty/Widgets/Box.hs @@ -218,9 +218,11 @@ return wRef +-- |Get a reference to the first (left or top) widget in a box. getFirstChild :: Widget (Box a b) -> IO (Widget a) getFirstChild = (boxFirst <~~) +-- |Get a reference to the second (right or bottom) widget in a box. getSecondChild :: Widget (Box a b) -> IO (Widget b) getSecondChild = (boxSecond <~~) @@ -235,12 +237,13 @@ setBoxSpacing wRef spacing return wRef +-- |Get the child size policy for a box. getBoxChildSizePolicy :: Widget (Box a b) -> IO 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. +-- policy uses an invalid percentage value, which must be between 0 +-- and 100 inclusive. setBoxChildSizePolicy :: Widget (Box a b) -> ChildSizePolicy -> IO () setBoxChildSizePolicy b spol = do case spol of @@ -325,7 +328,12 @@ -> Int -> Int -> IO (Image, Image) -renderBoxFixed s ctx this firstDim secondDim = do +renderBoxFixed s ctx this firstDim secondDim + -- If the box is too large to fit in the available space (since it + -- has fixed dimensions and can't be scaled), return the empty + -- image. + | toEnum firstDim + toEnum secondDim > regDimension this s = return (empty_image, empty_image) + | otherwise = do let withDim = withDimension this img1 <- render (boxFirst this) (s `withDim` (toEnum firstDim)) ctx img2 <- render (boxSecond this) (s `withDim` (toEnum secondDim)) ctx diff --git a/src/Graphics/Vty/Widgets/Button.hs b/src/Graphics/Vty/Widgets/Button.hs --- a/src/Graphics/Vty/Widgets/Button.hs +++ b/src/Graphics/Vty/Widgets/Button.hs @@ -47,6 +47,7 @@ newButton :: String -> IO Button newButton msg = do t <- plainText msg + setTextAppearFocused t True w <- return t >>= withPadding (padLeftRight 3) >>= diff --git a/src/Graphics/Vty/Widgets/Core.hs b/src/Graphics/Vty/Widgets/Core.hs --- a/src/Graphics/Vty/Widgets/Core.hs +++ b/src/Graphics/Vty/Widgets/Core.hs @@ -59,6 +59,7 @@ , FocusGroupError(..) , newFocusGroup , mergeFocusGroups + , appendFocusGroup , resetFocusGroup , addToFocusGroup , focusNext @@ -80,9 +81,11 @@ import Graphics.Vty.Widgets.Skins import Graphics.Vty.Widgets.Events +-- |The class of types with a "normal" attribute. class HasNormalAttr w where setNormalAttribute :: w -> Attr -> IO () +-- |The class of types with a "focus" attribute. class HasFocusAttr w where setFocusAttribute :: w -> Attr -> IO () @@ -94,52 +97,114 @@ setFocusAttribute wRef a = updateWidget wRef $ \w -> w { focusAttribute = mergeAttr a (focusAttribute w) } +-- |Set the normal attribute on a value. withNormalAttribute :: (HasNormalAttr w) => Attr -> w -> IO w withNormalAttribute att w = do setNormalAttribute w att return w +-- |Set the focus attribute on a value. withFocusAttribute :: (HasFocusAttr w) => Attr -> w -> IO w withFocusAttribute att w = do setFocusAttribute w att return w +-- |Render errors. data RenderError = ImageTooBig String DisplayRegion DisplayRegion + -- ^An error indicating that a widget rendered to + -- an image which exceeded the available space. + -- Provides a representation of the violating + -- widget, the size of the available space, and the + -- size of the image which the widget's rendering + -- routine produced. deriving (Show, Typeable) instance Exception RenderError -data RenderContext = RenderContext { normalAttr :: Attr - , focusAttr :: Attr - , overrideAttr :: Attr - , skin :: Skin - } +-- |Context information used during the rendering process. +data RenderContext = + RenderContext { normalAttr :: Attr + -- ^The default normal attribute to use unless + -- overridden by a given widget. + , focusAttr :: Attr + -- ^The default focused attribute to use for a + -- focused widget unless overridden by a given + -- widget. + , overrideAttr :: Attr + -- ^An override attribute to be used to override + -- both the normal and focus attributes in effect + -- during rendering. Usually def_attr, this + -- attribute is used when child widgets need to have + -- their attributes overridden by a parent widget. + , skin :: Skin + -- ^The skin to use for rendering borders and other + -- interface elements which use the skin for their + -- representations. + } +-- |Get the normal attribute of a rendering context. getNormalAttr :: RenderContext -> Attr getNormalAttr ctx = mergeAttrs [ overrideAttr ctx, normalAttr ctx ] +-- |Default context settings. defaultContext :: RenderContext -defaultContext = RenderContext def_attr def_attr def_attr unicodeSkin +defaultContext = RenderContext def_attr (white `on` blue) def_attr unicodeSkin +-- |The type of widget implementations, parameterized on the type of +-- the widget's state. data WidgetImpl a = WidgetImpl { state :: a + -- ^The state of the widget. , render_ :: Widget a -> DisplayRegion -> RenderContext -> IO Image + -- ^The rendering routine of the widget. Takes the widget itself, + -- a region indicating how much space the rendering process has to + -- work with, and a rendering context to be used to determine + -- attribute and skin settings. This MUST return an image which + -- is no larger than the specified rendering region. , growHorizontal_ :: a -> IO Bool + -- ^Returns whether the widget will automatically grow to fill + -- available horizontal space. , growVertical_ :: a -> IO Bool + -- ^Returns whether the widget will automatically grow to fill + -- available vertical space. , currentSize :: DisplayRegion + -- ^The size of the widget after its most recent rendering pass. , currentPosition :: DisplayRegion + -- ^The position of the widget after its most recent rendering + -- pass. , normalAttribute :: Attr + -- ^The normal (unfocused) attribute of the wiget. , focusAttribute :: Attr + -- ^The focused attribute of the widget. , setCurrentPosition_ :: Widget a -> DisplayRegion -> IO () + -- ^Sets the current position of the widget. Takes a widget + -- reference and a display region indicating the coordinates of + -- the widget's upper left corner. , keyEventHandler :: Widget a -> Key -> [Modifier] -> IO Bool + -- ^The widget's key event handler. Takes a widget reference, a + -- key event, and a list of keyboard modifiers. Returns whether + -- the keyboard event was handled. True indicates that the event + -- was handled and that event processing should halt; False + -- indicates that other event handlers, if present, may handle the + -- event. , gainFocusHandlers :: Handlers (Widget a) + -- ^List of handlers to be invoked when the widget gains focus. , loseFocusHandlers :: Handlers (Widget a) + -- ^List of handlers to be invoked when the widget loses focus. , focused :: Bool + -- ^Whether the widget is focused. , getCursorPosition_ :: Widget a -> IO (Maybe DisplayRegion) + -- ^Returns the current terminal cursor position. Should return + -- Nothing if the widget does not need to show a cursor, or Just + -- if it does. (For example, widgets receiving keyboard input for + -- text editing would should a cursor, but most won't need to.) } type Widget a = IORef (WidgetImpl a) +-- |Show a widget. Most widget show instances aren't going to contain +-- all of the widget state, but this at least gives an indication of +-- the widget type, which can be crucial for debugging. showWidget :: (Show a) => Widget a -> IO String showWidget wRef = show <$> readIORef wRef @@ -155,19 +220,31 @@ , " }" ] +-- |Does a widget grow horizontally? growHorizontal :: Widget a -> IO Bool growHorizontal w = do act <- growHorizontal_ <~ w st <- state <~ w act st +-- |Does a widget grow vertically? growVertical :: Widget a -> IO Bool growVertical w = do act <- growVertical_ <~ w st <- state <~ w act st -render :: (Show a) => Widget a -> DisplayRegion -> RenderContext -> IO Image +-- |Render a widget. This function should be called by widget +-- implementations, since it does more than 'render_'; this function +-- takes care of setting up attributes in the rendering context, +-- setting the size of the widget after it has been rendered, and +-- checking for size violations. May throw a 'RenderError'. +render :: (Show a) => + Widget a -- ^The widget to render. + -> DisplayRegion -- ^The amount of space in which to render the + -- widget. + -> RenderContext -- ^The rendering context to use. + -> IO Image render wRef sz ctx = do impl <- readIORef wRef @@ -189,30 +266,47 @@ setCurrentSize wRef $ DisplayRegion (image_width img) (image_height img) return img -renderAndPosition :: (Show a) => Widget a -> DisplayRegion -> DisplayRegion - -> RenderContext -> IO Image +-- |Render a widget and set its position after rendering is complete. +-- This is exported for internal use; widget implementations should +-- call 'render' instead. +renderAndPosition :: (Show a) => + Widget a -- ^The widget to render. + -> DisplayRegion -- ^The position at which to render + -- the widget. + -> DisplayRegion -- ^The amount of space in which to + -- render the widget. + -> RenderContext -- ^The rendering context to use. + -> IO 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 +-- |Set the current size of a widget. Exported for internal use. setCurrentSize :: Widget a -> DisplayRegion -> IO () setCurrentSize wRef newSize = modifyIORef wRef $ \w -> w { currentSize = newSize } +-- |Get the current size of the widget (its size after its most recent +-- rendering). getCurrentSize :: Widget a -> IO DisplayRegion getCurrentSize wRef = (return . currentSize) =<< (readIORef wRef) +-- |Set the current position of a widget. getCurrentPosition :: Widget a -> IO DisplayRegion getCurrentPosition wRef = currentPosition <$> (readIORef wRef) +-- |Set the current position of a widget. Exported for internal use. setCurrentPosition :: Widget a -> DisplayRegion -> IO () setCurrentPosition wRef pos = do updateWidget wRef $ \w -> w { currentPosition = pos } w <- readIORef wRef (setCurrentPosition_ w) wRef pos +-- |Create a new widget. Takes a widget implementation function and +-- passes it an implementation with default values. The caller MUST +-- set the 'state' and 'render_' functions of the implementation! newWidget :: (WidgetImpl a -> WidgetImpl a) -> IO (Widget a) newWidget f = do gfhs <- newHandlers @@ -238,25 +332,44 @@ updateWidget wRef f return wRef +-- |Default cursor positioning implementation used by 'newWidget'. defaultCursorInfo :: Widget a -> IO (Maybe DisplayRegion) defaultCursorInfo w = do sz <- getCurrentSize w pos <- getCurrentPosition w - return $ Just $ pos `plusWidth` (region_width sz - 1) + if region_width sz > 0 then + return $ Just $ pos `plusWidth` (region_width sz - 1) else + return Nothing +-- |Given a widget and key event information, invoke the widget's key +-- event handler with the event information. Returns whether the +-- event was handled. handleKeyEvent :: Widget a -> Key -> [Modifier] -> IO Bool handleKeyEvent wRef keyEvent mods = do act <- keyEventHandler <~ wRef act wRef keyEvent mods +-- |Given widgets A and B, causes any key events on widget A to be +-- relayed to widget B. Note that this does behavior constitutes an +-- ordinary key event handler from A's perspective, so if B does not +-- handle a given key event, subsequent key event handlers on A will +-- still get a chance to handle the event. This function is mostly +-- useful for wrapper widgets which don't do any event handling of +-- their own but want to ensure that all key events are relayed to the +-- wrapped widget. relayKeyEvents :: Widget a -> Widget b -> IO () relayKeyEvents a b = a `onKeyPressed` \_ k mods -> handleKeyEvent b k mods +-- |Given widgets A and B, cause all focus gain and loss events on A +-- to cause focus gain and loss for B. relayFocusEvents :: Widget a -> Widget b -> IO () relayFocusEvents a b = do a `onGainFocus` \_ -> focus b a `onLoseFocus` \_ -> unfocus b +-- |Given a widget and a key event handler, add the handler to the +-- widget's key event handler structure. The event handler is added +-- last, so any preexisting handlers will run before this one. onKeyPressed :: Widget a -> (Widget a -> Key -> [Modifier] -> IO Bool) -> IO () onKeyPressed wRef handler = do -- Create a new handler that calls this one but defers to the old @@ -272,47 +385,69 @@ updateWidget wRef $ \w -> w { keyEventHandler = combinedHandler } +-- |Focus a widget. Causes its focus gain event handlers to run. focus :: Widget a -> IO () focus wRef = do updateWidget wRef $ \w -> w { focused = True } fireEvent wRef (gainFocusHandlers <~) wRef +-- |Unfocus a widget. Causes its focus loss event handlers to run. unfocus :: Widget a -> IO () unfocus wRef = do updateWidget wRef $ \w -> w { focused = False } fireEvent wRef (loseFocusHandlers <~) wRef +-- |Given a widget and a focus gain event handler, add the handler to +-- the widget. The handler will be invoked when the widget receives +-- focus. onGainFocus :: Widget a -> (Widget a -> IO ()) -> IO () onGainFocus = addHandler (gainFocusHandlers <~) +-- |Given a widget and a focus loss event handler, add the handler to +-- the widget. The handler will be invoked when the widget loses +-- focus. onLoseFocus :: Widget a -> (Widget a -> IO ()) -> IO () onLoseFocus = addHandler (loseFocusHandlers <~) +-- |Convenience projection on the contents of an 'IORef'. (<~) :: (a -> b) -> IORef a -> IO b (<~) f wRef = (return . f) =<< (readIORef wRef) +-- |Convenience projection on the state of a widget. (<~~) :: (a -> b) -> Widget a -> IO b (<~~) f wRef = (return . f . state) =<< (readIORef wRef) +-- |Given a widget and an implementation transformer, apply the +-- transformer to the widget's implementation. updateWidget :: Widget a -> (WidgetImpl a -> WidgetImpl a) -> IO () updateWidget wRef f = modifyIORef wRef f +-- |Get the state value of a widget. getState :: Widget a -> IO a getState wRef = state <~ wRef +-- |Apply a state transformation function to a widget's state. updateWidgetState :: Widget a -> (a -> a) -> IO () updateWidgetState wRef f = do w <- readIORef wRef writeIORef wRef $ w { state = f (state w) } +-- |Focus group handling errors. data FocusGroupError = FocusGroupEmpty + -- ^Thrown when the desired operation could not + -- be completed because the focus group is empty. | FocusGroupBadIndex Int + -- ^Thrown when the specified focus group entry + -- index was invalid. deriving (Typeable, Show) instance Exception FocusGroupError +-- |The state type of widgets added to a focus group. data FocusEntry = forall a. FocusEntry (Widget a) +-- |Focus group. Represents an cycle of widgets which receive input +-- focus. data FocusGroup = FocusGroup { entries :: [Widget FocusEntry] , currentEntryNum :: Int , nextKey :: (Key, [Modifier]) @@ -341,6 +476,9 @@ return wRef +-- |Create a new focus group. Note that the focus group is itself a +-- widget; any input event handlers added to the focus group will fire +-- before input events are handled by the currently-focused widget. newFocusGroup :: IO (Widget FocusGroup) newFocusGroup = do wRef <- newWidget $ \w -> @@ -352,9 +490,13 @@ , getCursorPosition_ = \this -> do - eRef <- currentEntry this - (FocusEntry e) <- state <~ eRef - getCursorPosition e + cur <- currentEntryNum <~~ this + case cur of + (-1) -> return Nothing + _ -> do + eRef <- currentEntry this + (FocusEntry e) <- state <~ eRef + getCursorPosition e , keyEventHandler = \this key mods -> do @@ -375,14 +517,22 @@ } return wRef +-- |Set the keyboard event information used to change focus to the +-- next widget in a focus group. setFocusGroupNextKey :: Widget FocusGroup -> Key -> [Modifier] -> IO () setFocusGroupNextKey fg k mods = updateWidgetState fg $ \s -> s { nextKey = (k, mods) } +-- |Set the keyboard event information used to change focus to the +-- previous widget in a focus group. setFocusGroupPrevKey :: Widget FocusGroup -> Key -> [Modifier] -> IO () setFocusGroupPrevKey fg k mods = updateWidgetState fg $ \s -> s { prevKey = (k, mods) } +-- |Merge two focus groups. Given two focus groups A and B, this +-- returns a new focus group with all of the entries from A and B +-- added to it, in that order. Both A and B must be non-empty or +-- 'FocusGroupEmpty' will be thrown. mergeFocusGroups :: Widget FocusGroup -> Widget FocusGroup -> IO (Widget FocusGroup) mergeFocusGroups a b = do c <- newFocusGroup @@ -414,6 +564,36 @@ return c +-- |Given two focus groups A and B, append the entries of B to A, +-- mutating A in the process. Throws 'FocusGroupEmpty' if B is empty. +appendFocusGroup :: Widget FocusGroup -> Widget FocusGroup -> IO () +appendFocusGroup a b = do + aEntries <- entries <~~ a + bEntries <- entries <~~ b + + when (null bEntries) $ + throw FocusGroupEmpty + + updateWidgetState a $ \s -> s { entries = (entries s) ++ bEntries + , currentEntryNum = 0 + } + + -- Now we need to be sure that we have the event handlers set + -- correctly on each widget. The reason we don't just call + -- addToFocusGroup on each entry's widget is because the user may + -- have added event handlers to the FocusEntries themselves, and we + -- want to preserve those, so we extract the widget from the focus + -- entry to add the onGainFocus handler, but use the existing + -- FocusEntries when constructing the new focus group. + forM_ (zip [(length aEntries)..] bEntries) $ \(i, e) -> do + (FocusEntry w) <- state <~ e + w `onGainFocus` (const $ setCurrentFocus a i) + +-- |Reset a focus group. This ensures that the focus group's state is +-- coherent by calling 'focus' on the group's focused entry and +-- 'unfocus' on all the rest. This is for internal use, but is used +-- by the 'Collection' switching implementation to ensure that focus +-- state is sane. resetFocusGroup :: Widget FocusGroup -> IO () resetFocusGroup fg = do cur <- currentEntryNum <~~ fg @@ -423,11 +603,13 @@ when (cur >= 0) $ focus =<< currentEntry fg +-- |Get the desired cursor position, if any, for a widget. getCursorPosition :: Widget a -> IO (Maybe DisplayRegion) getCursorPosition wRef = do ci <- getCursorPosition_ <~ wRef ci wRef +-- |Return the current focus entry of a focus group. currentEntry :: Widget FocusGroup -> IO (Widget FocusEntry) currentEntry wRef = do es <- entries <~~ wRef @@ -435,6 +617,13 @@ when (i == -1) $ throw FocusGroupEmpty return (es !! i) +-- |Add a widget to a focus group. This returns a focus group entry +-- which wraps the specified widget; the focus group entry is also a +-- widget and can take key event handlers and the like. During input +-- event processing, the focus group entry receives keyboard events +-- and passes them on to the wrapped widget. If you want a widget to +-- have specific event handling in a particular interface, add event +-- handlers to its focus entry/entries instead of the widget itself. addToFocusGroup :: (Show a) => Widget FocusGroup -> Widget a -> IO (Widget FocusEntry) addToFocusGroup cRef wRef = do eRef <- newFocusEntry wRef @@ -454,6 +643,7 @@ return eRef +-- |Focus the next widget in a focus group. focusNext :: Widget FocusGroup -> IO () focusNext wRef = do st <- getState wRef @@ -464,6 +654,7 @@ (entries st) !! 0 focus nextEntry +-- |Focus the previous widget in a focus group. focusPrevious :: Widget FocusGroup -> IO () focusPrevious wRef = do st <- getState wRef diff --git a/src/Graphics/Vty/Widgets/DirBrowser.hs b/src/Graphics/Vty/Widgets/DirBrowser.hs --- a/src/Graphics/Vty/Widgets/DirBrowser.hs +++ b/src/Graphics/Vty/Widgets/DirBrowser.hs @@ -3,6 +3,7 @@ module Graphics.Vty.Widgets.DirBrowser ( DirBrowser(dirBrowserWidget) , BrowserSkin(..) + , DirBrowserWidgetType , newDirBrowser , withAnnotations , setDirBrowserPath @@ -32,15 +33,16 @@ 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))) +type DirBrowserWidgetType = + Box + (Box (Box FormattedText FormattedText) HFill) + (Box + (List [Char] (Box FormattedText FormattedText)) + (Box + (Box (Box FormattedText FormattedText) HFill) + FormattedText)) -data DirBrowser = DirBrowser { dirBrowserWidget :: T +data DirBrowser = DirBrowser { dirBrowserWidget :: Widget DirBrowserWidgetType , dirBrowserList :: Widget (List String (Box FormattedText FormattedText)) , dirBrowserPath :: IORef FilePath , dirBrowserPathDisplay :: Widget FormattedText diff --git a/src/Graphics/Vty/Widgets/Group.hs b/src/Graphics/Vty/Widgets/Group.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Group.hs @@ -0,0 +1,119 @@ +-- |Widget groups. Useful for when you need to swap out many +-- instances of the same widget type in a specific location in an +-- interface. A group has a currently active widget which can be +-- changed with 'setCurrentGroupEntry'. Add a widget to a group with +-- 'addToGroup'; 'addToGroup' returns an action which can be used to +-- set the specified widget as the group's active widget. +module Graphics.Vty.Widgets.Group + ( Group + , newGroup + , addToGroup + , setCurrentGroupEntry + ) +where + +import Control.Monad ( when ) +import Graphics.Vty ( empty_image ) +import Graphics.Vty.Widgets.Core + +-- |A group of widgets of a specified type. +data Group a = Group { entries :: [Widget a] + , currentEntryNum :: Int + } + +instance Show (Group a) where + show grp = concat [ "Group {" + , " entries = (" ++ (show $ length $ entries grp) ++ ")" + , ", currentEntryNum = " ++ (show $ currentEntryNum grp) + , "}" + ] + +-- |Create a new empty widget group. +newGroup :: (Show a) => IO (Widget (Group a)) +newGroup = do + wRef <- newWidget $ \w -> + w { state = Group { entries = [] + , currentEntryNum = -1 + } + + , getCursorPosition_ = + \this -> + getCursorPosition =<< currentEntry this + + , growHorizontal_ = + \this -> + growHorizontal $ currentEntry' this + + , growVertical_ = + \this -> + growVertical $ currentEntry' this + + , keyEventHandler = + \this key mods -> do + cur <- currentEntryNum <~~ this + case cur of + (-1) -> return False + _ -> do + e <- currentEntry this + handleKeyEvent e key mods + + -- Should never be rendered. + , render_ = \this sz ctx -> do + cur <- currentEntryNum <~~ this + case cur of + (-1) -> return empty_image + _ -> do + e <- currentEntry this + render e sz ctx + } + + let focusCurrent = focus =<< currentEntry wRef + unfocusCurrent = unfocus =<< currentEntry wRef + + wRef `onGainFocus` const focusCurrent + wRef `onLoseFocus` const unfocusCurrent + + return wRef + +currentEntry :: Widget (Group a) -> IO (Widget a) +currentEntry grp = do + st <- getState grp + return $ currentEntry' st + +currentEntry' :: Group a -> Widget a +currentEntry' st = do + case currentEntryNum st of + (-1) -> error "currentEntry should not be called on an empty group" + i -> entries st !! i + +-- |Add a widget to a group. Returns an action which, when evaluated, +-- will update the group state so that its currently-active widget is +-- the one passed to this function. +addToGroup :: Widget (Group a) -> Widget a -> IO (IO ()) +addToGroup grp w = do + numEntries <- (length . entries) <~~ grp + updateWidgetState grp $ \s -> s { entries = entries s ++ [w] + , currentEntryNum = if currentEntryNum s == (-1) + then 0 + else currentEntryNum s + } + return $ setCurrentGroupEntry grp numEntries + +-- |Set a group's current entry to the specified index. Use with +-- care. +setCurrentGroupEntry :: Widget (Group a) -> Int -> IO () +setCurrentGroupEntry grp i = do + num <- (length . entries) <~~ grp + when (i < 0 || i >= num) $ error "setCurrentGroupEntry got bad index" + + foc <- focused <~ grp + cur <- currentEntryNum <~~ grp + + when (cur >= 0) $ do + w <- currentEntry grp + when foc $ unfocus w + + updateWidgetState grp $ \s -> s { currentEntryNum = i } + + w' <- currentEntry grp + when foc $ focus w' diff --git a/src/Graphics/Vty/Widgets/Table.hs b/src/Graphics/Vty/Widgets/Table.hs --- a/src/Graphics/Vty/Widgets/Table.hs +++ b/src/Graphics/Vty/Widgets/Table.hs @@ -455,12 +455,17 @@ return $ toEnum ((max 0 ((fromEnum $ region_width sz) - totalFixed - edgeWidth - colWidth)) `div` numAuto) +-- |Add a heading row to a table. Adds a row using the specified +-- |labels and attribute. Returns the widgets it constructed as a +-- |side-effect in case you want to do something with them. addHeadingRow :: Widget Table -> Attr -> [String] -> IO [Widget FormattedText] addHeadingRow tbl attr labels = do ws <- mapM (\s -> plainText s >>= withNormalAttribute attr) labels addRow tbl ws return ws +-- |Add a heading row to a table. Adds a row using the specified +-- |labels and attribute. addHeadingRow_ :: Widget Table -> Attr -> [String] -> IO () addHeadingRow_ tbl attr labels = addHeadingRow tbl attr labels >> return () diff --git a/src/Graphics/Vty/Widgets/Text.hs b/src/Graphics/Vty/Widgets/Text.hs --- a/src/Graphics/Vty/Widgets/Text.hs +++ b/src/Graphics/Vty/Widgets/Text.hs @@ -8,12 +8,16 @@ ( FormattedText -- *Constructing Text Widgets , plainText + , plainTextWithAttrs , textWidget -- *Setting Widget Contents , setText , setTextWithAttrs + , setTextFormatter + , setTextAppearFocused -- *Formatting , Formatter + , getTextFormatter , (&.&) , highlight , nullFormatter @@ -48,19 +52,30 @@ data FormattedText = FormattedText { text :: TextStream Attr , formatter :: Formatter + , useFocusAttribute :: Bool } instance Show FormattedText where - show (FormattedText t _) = concat [ "FormattedText { " - , "text = ", show t - , ", formatter = ... }" - ] + show (FormattedText t _ f) = concat [ "FormattedText { " + , "text = ", show t + , ", formatter = ..." + , ", useFocusAttribute = " ++ show f + , " }" + ] -- |Construct a Widget directly from a String. This is recommended if -- you don't need to use a 'Formatter'. plainText :: String -> IO (Widget FormattedText) plainText = textWidget nullFormatter +-- |Construct a Widget directly from a list of strings and their +-- attributes. +plainTextWithAttrs :: [(String, Attr)] -> IO (Widget FormattedText) +plainTextWithAttrs pairs = do + w <- textWidget nullFormatter "" + setTextWithAttrs w pairs + return w + -- |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 @@ -102,16 +117,35 @@ wRef <- newWidget $ \w -> w { state = FormattedText { text = TS [] , formatter = format + , useFocusAttribute = False } , getCursorPosition_ = const $ return Nothing , render_ = \this size ctx -> do ft <- getState this f <- focused <~ this - renderText (text ft) f (formatter ft) size ctx + appearFocused <- useFocusAttribute <~~ this + renderText (text ft) (f && appearFocused) (formatter ft) size ctx } setText wRef s return wRef + +-- |Set the formatter for the text. +setTextFormatter :: Widget FormattedText -> Formatter -> IO () +setTextFormatter wRef f = updateWidgetState wRef $ \st -> + st { formatter = f } + +-- |Get the formatter for the text. +getTextFormatter :: Widget FormattedText -> IO Formatter +getTextFormatter = (formatter <~~) + +-- |Set whether a text widget can appear focused by using the +-- context-specific focus attribute when the widget has the focus. +-- This setting defaults to False; some widgets which embed text +-- widgets may need to turn this on. +setTextAppearFocused :: Widget FormattedText -> Bool -> IO () +setTextAppearFocused wRef val = updateWidgetState wRef $ \st -> + st { useFocusAttribute = val } -- |Set the text value of a 'FormattedText' widget. The specified -- string will be 'tokenize'd. diff --git a/src/PhoneInputDemo.hs b/src/PhoneInputDemo.hs --- a/src/PhoneInputDemo.hs +++ b/src/PhoneInputDemo.hs @@ -4,7 +4,7 @@ import Control.Monad -import Graphics.Vty +import Graphics.Vty hiding (pad) import Graphics.Vty.Widgets.All data PhoneNumber = PhoneNumber String String String diff --git a/vty-ui.cabal b/vty-ui.cabal --- a/vty-ui.cabal +++ b/vty-ui.cabal @@ -1,5 +1,5 @@ Name: vty-ui -Version: 1.2 +Version: 1.3 Synopsis: An interactive terminal user interface library for Vty Description: An extensible library of user interface widgets @@ -16,7 +16,7 @@ Build-Type: Simple License: BSD3 License-File: LICENSE -Cabal-Version: >= 1.2 +Cabal-Version: >= 1.6 Homepage: http://codevine.org/vty-ui/ Data-Files: @@ -49,6 +49,7 @@ doc/ch4/DirBrowser.tex doc/ch4/Edit.tex doc/ch4/Fills.tex + doc/ch4/Groups.tex doc/ch4/Fixed.tex doc/ch4/FormattedText.tex doc/ch4/main.tex @@ -62,7 +63,12 @@ doc/vty-ui-users-manual.tex doc/title_page.tex doc/toc.tex + doc/minted.sty +Source-Repository head + type: git + location: git://github.com/jtdaugherty/vty-ui.git + Flag testing Description: Build for testing Default: False @@ -74,13 +80,13 @@ Library Build-Depends: base >= 4 && < 5, - vty >= 4.6 && < 4.7, + vty >= 4.6 && < 4.8, containers >= 0.2 && < 0.5, regex-pcre >= 0.94 && < 0.95, regex-base >= 0.93 && < 0.94, directory >= 1.0 && < 1.2, filepath >= 1.1 && < 1.3, - unix >= 2.4 && < 2.5, + unix >= 2.4 && < 2.6, mtl >= 2.0 && < 2.1, stm >= 2.1 && < 2.3, array >= 0.3 && < 0.4 @@ -111,6 +117,7 @@ Graphics.Vty.Widgets.Button Graphics.Vty.Widgets.ProgressBar Graphics.Vty.Widgets.DirBrowser + Graphics.Vty.Widgets.Group Text.Trans.Tokenize Executable vty-ui-tests @@ -143,7 +150,7 @@ Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.1, - vty >= 4.6 && < 4.7 + vty >= 4.6 && < 4.8 if !flag(demos) Buildable: False @@ -160,7 +167,7 @@ time >= 1.1 && < 1.3, old-locale >= 1.0 && < 1.1, regex-pcre >= 0.94 && < 0.95, - vty >= 4.6 && < 4.7 + vty >= 4.6 && < 4.8 if !flag(demos) Buildable: False @@ -173,7 +180,7 @@ Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.1, - vty >= 4.6 && < 4.7 + vty >= 4.6 && < 4.8 if !flag(demos) Buildable: False @@ -186,7 +193,7 @@ Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.1, - vty >= 4.6 && < 4.7 + vty >= 4.6 && < 4.8 if !flag(demos) Buildable: False @@ -199,6 +206,6 @@ Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.1, - vty >= 4.6 && < 4.7 + vty >= 4.6 && < 4.8 if !flag(demos) Buildable: False