vty-ui 1.2 → 1.3
raw patch · 19 files changed
+705/−47 lines, 19 filesdep ~unixdep ~vtysetup-changed
Dependency ranges changed: unix, vty
Files
- Setup.hs +0/−2
- Setup.lhs +3/−0
- doc/ch4/FormattedText.tex +7/−0
- doc/ch4/Groups.tex +42/−0
- doc/ch4/main.tex +3/−2
- doc/macros.tex +1/−1
- doc/minted.sty +227/−0
- src/ComplexDemo.hs +1/−1
- src/Graphics/Vty/Widgets/All.hs +2/−0
- src/Graphics/Vty/Widgets/Borders.hs +13/−2
- src/Graphics/Vty/Widgets/Box.hs +11/−3
- src/Graphics/Vty/Widgets/Button.hs +1/−0
- src/Graphics/Vty/Widgets/Core.hs +204/−13
- src/Graphics/Vty/Widgets/DirBrowser.hs +10/−8
- src/Graphics/Vty/Widgets/Group.hs +119/−0
- src/Graphics/Vty/Widgets/Table.hs +5/−0
- src/Graphics/Vty/Widgets/Text.hs +39/−5
- src/PhoneInputDemo.hs +1/−1
- vty-ui.cabal +16/−9
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
doc/ch4/FormattedText.tex view
@@ -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.
+ doc/ch4/Groups.tex view
@@ -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.
doc/ch4/main.tex view
@@ -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}
doc/macros.tex view
@@ -1,6 +1,6 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.2}+\newcommand{\vtyuiversion}{1.3} \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}}
+ doc/minted.sty view
@@ -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 <nul: /p x=\string^\@percentchar \string~$PATH:i>>\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'.
src/ComplexDemo.hs view
@@ -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.
src/Graphics/Vty/Widgets/All.hs view
@@ -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
src/Graphics/Vty/Widgets/Borders.hs view
@@ -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
src/Graphics/Vty/Widgets/Box.hs view
@@ -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
src/Graphics/Vty/Widgets/Button.hs view
@@ -47,6 +47,7 @@ newButton :: String -> IO Button newButton msg = do t <- plainText msg+ setTextAppearFocused t True w <- return t >>= withPadding (padLeftRight 3) >>=
src/Graphics/Vty/Widgets/Core.hs view
@@ -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
src/Graphics/Vty/Widgets/DirBrowser.hs view
@@ -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
+ src/Graphics/Vty/Widgets/Group.hs view
@@ -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'
src/Graphics/Vty/Widgets/Table.hs view
@@ -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 ()
src/Graphics/Vty/Widgets/Text.hs view
@@ -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.
src/PhoneInputDemo.hs view
@@ -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
vty-ui.cabal view
@@ -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