vty-ui 1.4 → 1.5
raw patch · 34 files changed
+913/−529 lines, 34 filesdep +vectordep ~arraydep ~filepathdep ~timenew-component:exe:vty-ui-edit-demonew-component:exe:vty-ui-progressbar-demo
Dependencies added: vector
Dependency ranges changed: array, filepath, time
Files
- doc/ch3/deferring_to_children.tex +2/−3
- doc/ch3/implementing_composite_widgets.tex +0/−4
- doc/ch3/implementing_event_handlers.tex +4/−6
- doc/ch3/new_widget_type.tex +22/−24
- doc/ch4/Edit.tex +27/−15
- doc/ch4/ProgressBar.tex +14/−6
- doc/ch4/Table.tex +1/−1
- doc/macros.tex +3/−2
- src/ComplexDemo.hs +8/−6
- src/EditDemo.hs +39/−0
- src/Graphics/Vty/Widgets/Alignment.hs +16/−0
- src/Graphics/Vty/Widgets/All.hs +2/−0
- src/Graphics/Vty/Widgets/Borders.hs +9/−10
- src/Graphics/Vty/Widgets/Box.hs +21/−20
- src/Graphics/Vty/Widgets/Centering.hs +4/−6
- src/Graphics/Vty/Widgets/CheckBox.hs +11/−10
- src/Graphics/Vty/Widgets/Core.hs +38/−30
- src/Graphics/Vty/Widgets/Edit.hs +350/−144
- src/Graphics/Vty/Widgets/EventLoop.hs +1/−3
- src/Graphics/Vty/Widgets/Fills.hs +4/−6
- src/Graphics/Vty/Widgets/Fixed.hs +10/−10
- src/Graphics/Vty/Widgets/Group.hs +5/−6
- src/Graphics/Vty/Widgets/Limits.hs +6/−6
- src/Graphics/Vty/Widgets/List.hs +36/−28
- src/Graphics/Vty/Widgets/Padding.hs +3/−4
- src/Graphics/Vty/Widgets/ProgressBar.hs +80/−32
- src/Graphics/Vty/Widgets/Table.hs +11/−20
- src/Graphics/Vty/Widgets/Text.hs +25/−11
- src/Graphics/Vty/Widgets/Util.hs +4/−3
- src/ListDemo.hs +60/−96
- src/PhoneInputDemo.hs +0/−4
- src/ProgressBarDemo.hs +56/−0
- src/Text/Trans/Tokenize.hs +7/−7
- vty-ui.cabal +34/−6
doc/ch3/deferring_to_children.tex view
@@ -24,9 +24,8 @@ \begin{haskellcode} newWrapper :: Widget a -> IO (Widget (Wrapper a)) newWrapper child = do- wRef <- newWidget $ \w ->- w { state = Wrapper child- , growHorizontal_ = growHorizontal child+ wRef <- newWidget (Wrapper child) $ \w ->+ w { growHorizontal_ = growHorizontal child , growVertical_ = growVertical child , setCurrentPosition_ = \_ pos = setCurrentPosition child pos
doc/ch3/implementing_composite_widgets.tex view
@@ -78,10 +78,6 @@ (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
doc/ch3/implementing_event_handlers.tex view
@@ -44,11 +44,9 @@ newTempMonitor :: IO (Widget TempMonitor) newTempMonitor = do handlers <- newHandlers- wRef <- newWidget $ \w ->- w { state = TempMonitor { tempChangeHandlers = handlers- }- }-+ let st = TempMonitor { tempChangeHandlers = handlers+ }+ wRef <- newWidget st id return wRef \end{haskellcode} @@ -87,7 +85,7 @@ when (newTemp > maxTemp) $ error "It's too hot!" \end{haskellcode} -The last thing it do is to actually ``fire'' the event that these+The last thing it does 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
doc/ch3/new_widget_type.tex view
@@ -26,9 +26,9 @@ \begin{haskellcode} newCounter :: Int -> IO (Widget Counter) newCounter initialValue = do- wRef <- newWidget $ \w ->- w { state = Counter initialValue- , render_ =+ let st = Counter initialValue+ wRef <- newWidget st $ \w ->+ w { render_ = \this size ctx -> do (Counter v) <- getState this return $ string (getNormalAttr ctx) (show v)@@ -39,30 +39,27 @@ the code: \begin{haskellcode}- wRef <- newWidget $ \w -> ...+ let st = Counter initialValue+ wRef <- newWidget st $ \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.+as \fw{render\_}. 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. -\begin{haskellcode}- state = Counter initialValue-\end{haskellcode}+The \fw{newWidget} function takes an initial state of the widget (of+type \fw{a}) and a transformation function \fw{WidgetImpl a ->+ WidgetImpl a}, creates a new \fw{WidgetImpl}, sets its \fw{state} to+the initial state provided, and transforms it with the transformation+function. We do this to specify the behavior of the widget beyond the+defaults, which are specified in the \fw{newWidget} function. -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.+Here is the \fw{render\_} function which will actually construct a Vty+\fw{Image} to be displayed in the terminal: \begin{haskellcode} render_ =@@ -74,10 +71,8 @@ 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:+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@@ -114,6 +109,9 @@ The \fw{getState} function takes a \fw{Widget a} and returns its \fw{state} field. In this case, it returns the \fw{Counter} value.+It's important to use \fw{getState} instead of just referring to+\fw{st} in the example above, since you'll need to make sure to get+the latest state value at the time \fw{render\_} is called. \begin{haskellcode} let s = show v@@ -134,7 +132,7 @@ 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}.+override attribute, see Section \ref{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
doc/ch4/Edit.tex view
@@ -2,13 +2,17 @@ \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.+This widget makes it possible to edit text with some Emacs-style key+bindings. -An \fw{Edit} widget is simple to create:+An \fw{Edit} widget is simple to create. You can create \fw{Edit}+widgets in two modes: single- and multi-line: \begin{haskellcode}- e <- editWidget+ -- Single-line text editor:+ e1 <- editWidget+ -- Multi-line text editor:+ e2 <- multiLineEditWidget \end{haskellcode} \fw{Edit} widgets can be laid out in the usual way:@@ -34,16 +38,21 @@ 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.+\item \fw{Enter} -- ``activate'' the \fw{Edit} widget if it is a+ single-line widget; if it is multi-line, insert a new line at the+ cursor position. \end{itemize} +Note that \fw{Tab} will not be handled by \fw{Edit} widgets because it+is used to change focus.+ 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.+ \fw{Enter} in a single-line \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.@@ -62,14 +71,17 @@ 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.+\item \fw{getEditLineLimit}, \fw{setEditLineLimit} -- manipulate the+ limit on the number of lines that the text widget may hold. Takes+ \fw{Maybe Int} where \fw{Nothing} indicates no limit.+ \fw{setEditLineLimit \$ Just 0} is a no-op. \end{itemize} \subsubsection{Growth Policy} -\fw{Edit} widgets grow only horizontally and are always one row high.+Single-line \fw{Edit} widgets -- those created by \fw{editWidget} --+grow only horizontally and are always one row high. Multi-line edit+widgets -- those created by \fw{multiLineEditWidget} -- always grow in+both dimensions. To manage this behavior, you can use one of the+``fixed'' family of widgets to control their sizes (see Section+\ref{sec:fixed}).
doc/ch4/ProgressBar.tex view
@@ -5,19 +5,27 @@ 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+function. The function takes two \fw{Attr} arguments indicating the+attributes to be used for the complete and incomplete portions of the progress bar, respectively: \begin{haskellcode}- bar <- newProgressBar blue white+ bar <- newProgressBar (blue `on` white) (white `on` blue) \end{haskellcode} -\fw{ProgressBar}s are composite widgets; to lay them out in your-applications, use the \fw{progressBarWidget} function:+\fw{ProgressBar}s take \fw{Attr} values because these widgets support+text labels. You can set the label and its alignment as follows: \begin{haskellcode}- ui <- (plainText "Progress: ") <--> (return $ progressBarWidget bar)+ setProgressText bar "Working..."+ setProgressTextAlignment bar AlignCenter+\end{haskellcode}++\fw{ProgressBar}s can be laid out in your interface like any other+widget:++\begin{haskellcode}+ ui <- (plainText "Progress: ") <--> (return bar) \end{haskellcode} A \fw{ProgressBar} tracks progress as an \fw{Int} n ($0 \le n \le
doc/ch4/Table.tex view
@@ -75,7 +75,7 @@ \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+type class provided by the \fw{Alignment} module. This type class provides an \fw{align} function which we can use to set the default cell alignment for the column:
doc/macros.tex view
@@ -1,9 +1,10 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.4}+\newcommand{\vtyuiversion}{1.5} \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}} % Defines 'haskellcode' environment to have these options.-\newminted{haskell}{samepage,fontsize=\small}+\definecolor{mintedBg}{rgb}{0.95,0.95,0.95}+\newminted{haskell}{samepage,fontsize=\small,bgcolor=mintedBg}
src/ComplexDemo.hs view
@@ -55,7 +55,9 @@ ] edit1 <- editWidget >>= withFocusAttribute (white `on` red)- edit2 <- editWidget+ edit2 <- multiLineEditWidget+ edit2box <- boxFixed 30 3 edit2+ setEditLineLimit edit2 $ Just 3 edit1Header <- textWidget wrap [] >>= withNormalAttribute headerAttr edit2Header <- textWidget wrap [] >>= withNormalAttribute headerAttr@@ -70,17 +72,17 @@ cbHeader <- plainText "" timeText <- plainText "" - prog <- newProgressBar red white- progLabel <- plainText ""+ prog <- newProgressBar (white `on` red) (red `on` white)+ setProgressTextAlignment prog AlignCenter 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 $ edit2Header .|. edit2box addRow table $ listHeader .|. customCell selector `pad` padNone addRow table $ emptyCell .|. timeText- addRow table $ progLabel .|. (progressBarWidget prog)+ addRow table $ emptyCell .|. prog rg `onRadioChange` \cb -> do s <- getCheckboxLabel cb@@ -90,7 +92,7 @@ setText cbHeader $ "you chose: " ++ show v prog `onProgressChange` \val ->- setText progLabel $ show val ++ " %"+ setProgressText prog $ "Progress (" ++ show val ++ " %)" edit1 `onChange` (setText edit1Header) edit2 `onChange` (setText edit2Header)
+ src/EditDemo.hs view
@@ -0,0 +1,39 @@+module Main where++import Graphics.Vty hiding (Button)+import Graphics.Vty.Widgets.All++main :: IO ()+main = do+ e1 <- multiLineEditWidget+ e2 <- multiLineEditWidget+ setEditLineLimit e2 $ Just 3+ e3 <- editWidget++ fg <- newFocusGroup+ _ <- addToFocusGroup fg e1+ _ <- addToFocusGroup fg e2+ _ <- addToFocusGroup fg e3++ be1 <- bordered =<< boxFixed 40 5 e1+ be2 <- bordered =<< boxFixed 40 3 e2+ be3 <- bordered =<< boxFixed 40 1 e3++ c <- centered =<< ((plainText "Multi-Line Editor (unlimited lines):")+ <--> (return be1)+ <--> (plainText "Multi-Line Editor (3 lines):")+ <--> (return be2)+ <--> (plainText "Single-Line Editor:")+ <--> (return be3)+ <--> (plainText "- Esc to quit\n\n- TAB to switch editors") >>= withBoxSpacing 1+ )++ coll <- newCollection+ _ <- addToCollection coll c fg++ fg `onKeyPressed` \_ k _ ->+ case k of+ KEsc -> shutdownUi >> return True+ _ -> return False++ runUi coll $ defaultContext { focusAttr = fgColor yellow }
+ src/Graphics/Vty/Widgets/Alignment.hs view
@@ -0,0 +1,16 @@+-- |This module provides a type and a type class for expressing+-- alignment. For concrete uses, see the Table and ProgressBar+-- modules.+module Graphics.Vty.Widgets.Alignment+ ( Alignment(..)+ , Alignable(..)+ )+where++-- |Column alignment values.+data Alignment = AlignCenter | AlignLeft | AlignRight+ deriving (Show)++-- |The class of types whose values or contents can be aligned.+class Alignable a where+ align :: a -> Alignment -> a
src/Graphics/Vty/Widgets/All.hs view
@@ -22,6 +22,7 @@ , module Graphics.Vty.Widgets.ProgressBar , module Graphics.Vty.Widgets.DirBrowser , module Graphics.Vty.Widgets.Group+ , module Graphics.Vty.Widgets.Alignment ) where @@ -47,3 +48,4 @@ import Graphics.Vty.Widgets.ProgressBar import Graphics.Vty.Widgets.DirBrowser import Graphics.Vty.Widgets.Group+import Graphics.Vty.Widgets.Alignment
src/Graphics/Vty/Widgets/Borders.hs view
@@ -69,9 +69,9 @@ -- attribute and character. hBorder :: IO (Widget HBorder) hBorder = do- wRef <- newWidget $ \w ->- w { state = HBorder def_attr ""- , growHorizontal_ = const $ return True+ let initSt = HBorder def_attr ""+ wRef <- newWidget initSt $ \w ->+ w { growHorizontal_ = const $ return True , render_ = renderHBorder } return wRef@@ -112,9 +112,9 @@ -- attribute and character. vBorder :: IO (Widget VBorder) vBorder = do- wRef <- newWidget $ \w ->- w { state = VBorder def_attr- , growVertical_ = const $ return True+ let initSt = VBorder def_attr+ wRef <- newWidget initSt $ \w ->+ w { growVertical_ = const $ return True , render_ = \this s ctx -> do VBorder attr <- getState this let attr' = mergeAttrs [ overrideAttr ctx@@ -142,10 +142,9 @@ -- |Wrap a widget in a bordering box. bordered :: (Show a) => Widget a -> IO (Widget (Bordered a)) bordered child = do- wRef <- newWidget $ \w ->- w { state = Bordered def_attr child ""-- , growVertical_ = const $ growVertical child+ let initSt = Bordered def_attr child ""+ wRef <- newWidget initSt $ \w ->+ w { growVertical_ = const $ growVertical child , growHorizontal_ = const $ growHorizontal child , keyEventHandler =
src/Graphics/Vty/Widgets/Box.hs view
@@ -134,27 +134,28 @@ box :: (Show a, Show b) => Orientation -> Int -> Widget a -> Widget b -> IO (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+ let initSt = 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+ , 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+ }++ wRef <- newWidget initSt $ \w ->+ w { growHorizontal_ = \b -> do case boxOrientation b of Vertical -> do h1 <- growHorizontal $ boxFirst b
src/Graphics/Vty/Widgets/Centering.hs view
@@ -24,9 +24,8 @@ -- |Wrap another widget to center it horizontally. hCentered :: (Show a) => Widget a -> IO (Widget (HCentered a)) hCentered ch = do- wRef <- newWidget $ \w ->- w { state = HCentered ch- , growHorizontal_ = const $ return True+ wRef <- newWidget (HCentered ch) $ \w ->+ w { growHorizontal_ = const $ return True , growVertical_ = \(HCentered child) -> growVertical child @@ -65,9 +64,8 @@ -- |Wrap another widget to center it vertically. vCentered :: (Show a) => Widget a -> IO (Widget (VCentered a)) vCentered ch = do- wRef <- newWidget $ \w ->- w { state = VCentered ch- , growVertical_ = const $ return True+ wRef <- newWidget (VCentered ch) $ \w ->+ w { growVertical_ = const $ return True , growHorizontal_ = const $ growHorizontal ch , render_ = \this s ctx -> do
src/Graphics/Vty/Widgets/CheckBox.hs view
@@ -155,16 +155,17 @@ 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_ =+ let initSt = CheckBox { checkboxLabel = label+ , checkboxChangeHandlers = cchs+ , leftBracketChar = '['+ , rightBracketChar = ']'+ , checkboxStates = states+ , currentState = fst $ states !! 0+ , checkboxFrozen = False+ }++ wRef <- newWidget initSt $ \w ->+ w { getCursorPosition_ = \this -> do pos <- getCurrentPosition this return $ Just (pos `plusWidth` 1)
src/Graphics/Vty/Widgets/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, BangPatterns #-} -- |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@@ -81,11 +81,12 @@ import Graphics.Vty.Widgets.Skins import Graphics.Vty.Widgets.Events --- |The class of types with a "normal" attribute.+-- |The class of types with a ''normal'' attribute. class HasNormalAttr w where setNormalAttribute :: w -> Attr -> IO () --- |The class of types with a "focus" attribute.+-- |The class of types with a ''focus'' attribute, i.e., a way of+-- visually indicating that the object has input focus. class HasFocusAttr w where setFocusAttribute :: w -> Attr -> IO () @@ -153,7 +154,7 @@ -- |The type of widget implementations, parameterized on the type of -- the widget's state. data WidgetImpl a = WidgetImpl {- state :: a+ state :: !a -- ^The state of the widget. , render_ :: Widget a -> DisplayRegion -> RenderContext -> IO Image -- ^The rendering routine of the widget. Takes the widget itself,@@ -286,7 +287,9 @@ -- |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 }+ modifyIORef wRef $ \w ->+ let new = w { currentSize = newSize }+ in seq new new -- |Get the current size of the widget (its size after its most recent -- rendering).@@ -304,17 +307,19 @@ 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+-- |Create a new widget. Takes an initial state value and a widget+-- implementation transformation and passes it an implementation with+-- default values.+newWidget :: a+ -> (WidgetImpl a -> WidgetImpl a)+ -> IO (Widget a)+newWidget initState f = do gfhs <- newHandlers lfhs <- newHandlers wRef <- newIORef $- WidgetImpl { state = undefined- , render_ = undefined+ WidgetImpl { state = initState+ , render_ = \_ _ _ -> return empty_image , growVertical_ = const $ return False , growHorizontal_ = const $ return False , setCurrentPosition_ = \_ _ -> return ()@@ -385,7 +390,10 @@ updateWidget wRef $ \w -> w { keyEventHandler = combinedHandler } --- |Focus a widget. Causes its focus gain event handlers to run.+-- |Focus a widget. Causes its focus gain event handlers to run. If+-- the widget is in a 'FocusGroup' and if that group's+-- currently-focused widget is some other widget, that widget will+-- lose the focus and its focus loss event handlers will be called. focus :: Widget a -> IO () focus wRef = do updateWidget wRef $ \w -> w { focused = True }@@ -420,7 +428,8 @@ -- |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+updateWidget wRef f = modifyIORef wRef $ \val -> let new = f val+ in seq new new -- |Get the state value of a widget. getState :: Widget a -> IO a@@ -430,7 +439,8 @@ updateWidgetState :: Widget a -> (a -> a) -> IO () updateWidgetState wRef f = do w <- readIORef wRef- writeIORef wRef $ w { state = f (state w) }+ writeIORef wRef $ let new = w { state = f (state w) }+ in seq new new -- |Focus group handling errors. data FocusGroupError = FocusGroupEmpty@@ -456,14 +466,14 @@ newFocusEntry :: (Show a) => Widget a -> IO (Widget FocusEntry) newFocusEntry chRef = do- wRef <- newWidget $ \w ->- w { state = FocusEntry chRef - , growHorizontal_ = const $ growHorizontal chRef+ let st = FocusEntry chRef++ wRef <- newWidget st $ \w ->+ w { growHorizontal_ = const $ growHorizontal chRef , growVertical_ = const $ growVertical chRef - , render_ =- \_ sz ctx -> render chRef sz ctx+ , render_ = \_ sz ctx -> render chRef sz ctx , setCurrentPosition_ = \this pos -> do@@ -481,14 +491,15 @@ -- before input events are handled by the currently-focused widget. newFocusGroup :: IO (Widget FocusGroup) newFocusGroup = do- wRef <- newWidget $ \w ->- w { state = FocusGroup { entries = []- , currentEntryNum = -1- , nextKey = (KASCII '\t', [])- , prevKey = (KASCII '\t', [MShift])- } - , getCursorPosition_ =+ let initSt = FocusGroup { entries = []+ , currentEntryNum = -1+ , nextKey = (KASCII '\t', [])+ , prevKey = (KASCII '\t', [MShift])+ }++ wRef <- newWidget initSt $ \w ->+ w { getCursorPosition_ = \this -> do cur <- currentEntryNum <~~ this case cur of@@ -511,9 +522,6 @@ do let e = entries st !! i handleKeyEvent e key mods-- -- Should never be rendered.- , render_ = \_ _ _ -> return empty_image } return wRef
src/Graphics/Vty/Widgets/Edit.hs view
@@ -1,114 +1,184 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--- |This module provides a one-line editing interface.+-- |This module provides a text-editing widget. Edit widgets can+-- operate in single- and multi-line modes.+--+-- Edit widgets support the following special keystrokes:+--+-- * Arrow keys to navigate the text+--+-- * @Enter@ - Activate single-line edit widgets or insert new lines+-- into multi-line widgets+--+-- * @Home@ / @Control-a@ - Go to beginning of the current line+--+-- * @End@ / @Control-e@ - Go to end of the current line+--+-- * @Control-k@ - Remove text from the cursor to the end of the line,+-- or remove the line if it is empty+--+-- * @Del@ / @Control-d@ - delete the current character+--+-- * @Backspace@ - delete the previous character module Graphics.Vty.Widgets.Edit ( Edit , editWidget+ , multiLineEditWidget , getEditText+ , getEditCurrentLine , setEditText , setEditCursorPosition , getEditCursorPosition- , setEditMaxLength+ , setEditLineLimit+ , getEditLineLimit , onActivate , onChange , onCursorMove ) where +import Control.Applicative ((<$>)) import Control.Monad 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+data Edit = Edit { currentText :: [String]+ , cursorRow :: Int+ , cursorColumn :: Int , displayStart :: Int , displayWidth :: Int+ , topRow :: Int+ , visibleRows :: Int , activateHandlers :: Handlers (Widget Edit) , changeHandlers :: Handlers String- , cursorMoveHandlers :: Handlers Int- , maxTextLength :: Maybe Int+ , cursorMoveHandlers :: Handlers (Int, Int)+ , lineLimit :: Maybe Int } instance Show Edit where show e = concat [ "Edit { " , "currentText = ", show $ currentText e- , ", cursorPosition = ", show $ cursorPosition e+ , ", cursorColumn = ", show $ cursorColumn e+ , ", cursorRow = ", show $ cursorRow e+ , ", topRow = ", show $ topRow e+ , ", lineLimit = ", show $ lineLimit e+ , ", visibleRows = ", show $ visibleRows e , ", displayStart = ", show $ displayStart e , ", displayWidth = ", show $ displayWidth e , " }" ] --- |Create a new editing widget.-editWidget :: IO (Widget Edit)-editWidget = do+editWidget' :: IO (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- }+ let initSt = Edit { currentText = [""]+ , cursorRow = 0+ , cursorColumn = 0+ , displayStart = 0+ , displayWidth = 0+ , topRow = 0+ , visibleRows = 1+ , activateHandlers = ahs+ , changeHandlers = chs+ , cursorMoveHandlers = cmhs+ , lineLimit = Nothing+ } - , growHorizontal_ = const $ return True+ wRef <- newWidget initSt $ \w ->+ w { growHorizontal_ = const $ return True+ , growVertical_ =+ \this -> do+ case lineLimit this of+ Just v | v == 1 -> return False+ _ -> return True+ , getCursorPosition_ = \this -> do f <- focused <~ this pos <- getCurrentPosition this- curPos <- cursorPosition <~~ this- start <- displayStart <~~ this+ curRow <- cursorRow <~~ this+ curCol <- cursorColumn <~~ this+ startCol <- displayStart <~~ this+ startRow <- topRow <~~ this if f then- return (Just $ pos `plusWidth` (toEnum (curPos - start))) else+ return (Just $ pos `plusWidth` (toEnum (curCol - startCol)) `plusHeight` (toEnum (curRow - startRow))) else return Nothing , render_ = \this size ctx -> do- setDisplayWidth this (fromEnum $ region_width size)+ resize this ( fromEnum $ region_height size+ , fromEnum $ region_width size )+ st <- getState this - let truncated = take (displayWidth st)- (drop (displayStart st) (currentText st))+ let truncated l = take (displayWidth st)+ (drop (displayStart st) l) + visibleLines = take (visibleRows st) $+ drop (topRow st) (currentText st)+ truncatedLines = truncated <$> visibleLines+ nAttr = mergeAttrs [ overrideAttr ctx , normalAttr ctx ] isFocused <- focused <~ this let attr = if isFocused then focusAttr ctx else nAttr+ lineWidget s = string attr s+ <|> char_fill attr ' ' (region_width size - (toEnum $ length s)) 1 - return $ string attr truncated- <|> char_fill attr ' ' (region_width size - (toEnum $ length truncated)) 1+ return $ vert_cat $ lineWidget <$> truncatedLines , keyEventHandler = editKeyEvent }+ return wRef++-- |Construct a text widget for editing a single line of text.+-- Single-line edit widgets will send activation events when the user+-- presses @Enter@ (see 'onActivate').+editWidget :: IO (Widget Edit)+editWidget = do+ wRef <- editWidget' setNormalAttribute wRef $ style underline setFocusAttribute wRef $ style underline+ setEditLineLimit wRef $ Just 1 return wRef --- |Set the maximum length of the edit widget's content.-setEditMaxLength :: Widget Edit -> Int -> IO ()-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 }+-- |Construct a text widget for editing multi-line documents.+-- Multi-line edit widgets never send activation events, since the+-- @Enter@ key inserts a new line at the cursor position.+multiLineEditWidget :: IO (Widget Edit)+multiLineEditWidget = do+ wRef <- editWidget'+ setEditLineLimit wRef Nothing+ return wRef +-- |Set the limit on the number of lines for the edit widget. Nothing+-- indicates no limit, while Just indicates a limit of the specified+-- number of lines.+setEditLineLimit :: Widget Edit -> Maybe Int -> IO ()+setEditLineLimit _ (Just v) | v <= 0 = return ()+setEditLineLimit w v = updateWidgetState w $ \st -> st { lineLimit = v }++-- |Get the current line limit, if any, for the edit widget.+getEditLineLimit :: Widget Edit -> IO (Maybe Int)+getEditLineLimit = (lineLimit <~~)++resize :: Widget Edit -> (Int, Int) -> IO ()+resize e (newHeight, newWidth) = do+ updateWidgetState e $ \st -> st { visibleRows = newHeight }+ setDisplayWidth e newWidth+ -- |Register handlers to be invoked when the edit widget has been -- ''activated'' (when the user presses Enter while the widget is--- focused).+-- focused). These handlers will only be invoked when a single-line+-- edit widget is activated; multi-line widgets never generate these+-- events. onActivate :: Widget Edit -> (Widget Edit -> IO ()) -> IO () onActivate = addHandler (activateHandlers <~~) @@ -133,55 +203,102 @@ -- |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 :: Widget Edit -> (Int -> IO ()) -> IO ()+onCursorMove :: Widget Edit -> ((Int, Int) -> IO ()) -> IO () onCursorMove = addHandler (cursorMoveHandlers <~~) --- |Get the current contents of the edit widget.+-- |Get the current contents of the edit widget. This returns all of+-- the lines of text in the widget, separated by newlines. getEditText :: Widget Edit -> IO String-getEditText = (currentText <~~)+getEditText = ((unlines . currentText) <~~) --- |Set the contents of the edit widget.+-- |Get the contents of the current line of the edit widget (the line+-- on which the cursor is positioned).+getEditCurrentLine :: Widget Edit -> IO String+getEditCurrentLine e = do+ ls <- currentText <~~ e+ curL <- cursorRow <~~ e+ return $ ls !! curL++setEditCurrentLine :: Widget Edit -> String -> IO ()+setEditCurrentLine e s = do+ ls <- currentText <~~ e+ curL <- cursorRow <~~ e++ updateWidgetState e $ \st ->+ st { currentText = repl curL s ls+ }++-- |Set the contents of the edit widget. Newlines will be used to+-- break up the text in multiline widgets. If the edit widget has a+-- line limit, only those lines within the limit will be set. setEditText :: Widget Edit -> String -> IO () setEditText wRef str = do oldS <- currentText <~~ wRef- maxLen <- maxTextLength <~~ wRef- s <- case maxLen of+ lim <- lineLimit <~~ wRef+ s <- case lim of Nothing -> return str- Just l -> return $ take l str- updateWidgetState wRef $ \st -> st { currentText = s }- when (oldS /= s) $ do+ Just l -> return $ unlines $ take l $ lines str+ updateWidgetState wRef $ \st -> st { currentText = lines s }+ when (oldS /= lines s) $ do gotoBeginning wRef notifyChangeHandlers wRef --- |Set the current edit widget cursor position. Invalid cursor--- positions will be ignored.-setEditCursorPosition :: Widget Edit -> Int -> IO ()-setEditCursorPosition wRef pos = do- oldPos <- getEditCursorPosition wRef- str <- getEditText wRef+-- |Set the current edit widget cursor position. The tuple is (row,+-- column) with each starting at zero. Invalid cursor positions will+-- be ignored.+setEditCursorPosition :: Widget Edit -> (Int, Int) -> IO ()+setEditCursorPosition wRef (newRow, newCol) = do+ ls <- currentText <~~ wRef - let newPos = if pos > (length str)- then length str- else if pos < 0- then 0- else pos+ -- First, check that the row is valid+ case newRow >= 0 && newRow < (length ls) of+ False -> return ()+ True -> do+ -- Then, if the row is valid, is the column valid for that row?+ -- It's legal for the new position to be *after* the last+ -- character (i.e., in the case of go-to-end)+ case newCol >= 0 && newCol <= (length (ls !! newRow)) of+ False -> return ()+ True -> do+ (oldRow, oldCol) <- getEditCursorPosition wRef+ when ((newRow, newCol) /= (oldRow, oldCol)) $+ do+ st <- getState wRef - when (newPos /= oldPos) $- do- updateWidgetState wRef $ \s ->- s { cursorPosition = newPos- }- notifyCursorMoveHandlers wRef+ let newDisplayStart = if newCol >= (displayStart st + displayWidth st)+ then newCol - displayWidth st + 1+ else if newCol < displayStart st+ then newCol+ else displayStart st+ newTopRow = if newRow < topRow st+ then newRow+ else if newRow >= (topRow st + visibleRows st)+ then newRow - visibleRows st + 1+ else topRow st --- |Get the edit widget's current cursor position.-getEditCursorPosition :: Widget Edit -> IO Int-getEditCursorPosition = (cursorPosition <~~)+ updateWidgetState wRef $ \s ->+ s { displayStart = newDisplayStart+ , topRow = newTopRow+ } + updateWidgetState wRef $ \s ->+ s { cursorRow = newRow+ , cursorColumn = newCol+ }+ notifyCursorMoveHandlers wRef++-- |Get the edit widget's current cursor position (row, column).+getEditCursorPosition :: Widget Edit -> IO (Int, Int)+getEditCursorPosition e = do+ r <- cursorRow <~~ e+ c <- cursorColumn <~~ e+ return (r, c)+ setDisplayWidth :: Widget Edit -> Int -> IO () setDisplayWidth this width = updateWidgetState this $ \s ->- let newDispStart = if cursorPosition s - displayStart s >= width- then cursorPosition s - width + 1+ let newDispStart = if cursorColumn s - displayStart s >= width+ then cursorColumn s - width + 1 else displayStart s in s { displayWidth = width , displayStart = newDispStart@@ -196,110 +313,199 @@ (KASCII 'd', [MCtrl]) -> delCurrentChar this >> return True (KLeft, []) -> moveCursorLeft this >> return True (KRight, []) -> moveCursorRight this >> return True+ (KUp, []) -> moveCursorUp this >> return True+ (KDown, []) -> moveCursorDown 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+ (KEnter, []) -> do+ lim <- lineLimit <~~ this+ case lim of+ Just 1 -> notifyActivateHandlers this >> return True+ _ -> insertLineAtPoint this >> return True _ -> return False +insertLineAtPoint :: Widget Edit -> IO ()+insertLineAtPoint e = do+ -- Bail if adding a new line would violate the line limit+ lim <- lineLimit <~~ e+ numLines <- (length . currentText) <~~ e++ let continue = case lim of+ Just v | numLines + 1 > v -> False+ _ -> True++ when continue $+ do+ -- Get information about current line so we can break the+ -- current line+ curL <- getEditCurrentLine e+ curCol <- cursorColumn <~~ e+ curRow <- cursorRow <~~ e+ let r1 = take curCol curL+ r2 = drop curCol curL+ setEditCurrentLine e r1+ updateWidgetState e $ \st ->+ st { currentText = inject (curRow + 1) r2 (currentText st)+ }+ notifyChangeHandlers e+ setEditCursorPosition e (curRow + 1, 0)+ 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+ curCol <- cursorColumn <~~ this+ curLine <- getEditCurrentLine this+ case null curLine of+ False -> setEditCurrentLine this $ take curCol curLine+ True -> do+ curRow <- cursorRow <~~ this+ numLines <- (length . currentText) <~~ this+ if curRow == 0 && numLines == 1 then+ return () else+ do+ let newRow = if curRow == numLines - 1 && numLines > 1+ then curRow - 1+ else curRow+ updateWidgetState this $ \st ->+ st { currentText = remove curRow (currentText st)+ }+ notifyChangeHandlers this+ setEditCursorPosition this (newRow, 0) deletePreviousChar :: Widget Edit -> IO () deletePreviousChar this = do- pos <- cursorPosition <~~ this- when (pos /= 0) $ do- moveCursorLeft this- delCurrentChar this+ curCol <- cursorColumn <~~ this+ curRow <- cursorRow <~~ this+ case curCol == 0 of+ True ->+ if curRow == 0+ then return ()+ else do+ curLine <- getEditCurrentLine this+ ls <- currentText <~~ this+ let prevLine = ls !! (curRow - 1)+ updateWidgetState this $ \st ->+ st { currentText = repl (curRow - 1) (prevLine ++ curLine)+ $ remove curRow (currentText st)+ }+ setEditCursorPosition this (curRow - 1, length prevLine)+ notifyChangeHandlers this + False -> do+ moveCursorLeft this+ delCurrentChar this+ gotoBeginning :: Widget Edit -> IO () gotoBeginning wRef = do updateWidgetState wRef $ \s -> s { displayStart = 0 }- setEditCursorPosition wRef 0+ curL <- cursorRow <~~ wRef+ setEditCursorPosition wRef (curL, 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+ curLine <- getEditCurrentLine wRef+ curRow <- cursorRow <~~ wRef+ setEditCursorPosition wRef (curRow, length curLine) +moveCursorUp :: Widget Edit -> IO ()+moveCursorUp wRef = do+ st <- getState wRef+ let newRow = if cursorRow st == 0+ then 0+ else cursorRow st - 1++ prevLine = currentText st !! (cursorRow st - 1)+ newCol = if cursorRow st == 0 || (cursorColumn st <= length prevLine)+ then cursorColumn st+ else length prevLine++ setEditCursorPosition wRef (newRow, newCol)++moveCursorDown :: Widget Edit -> IO ()+moveCursorDown wRef = do+ st <- getState wRef+ let newRow = if cursorRow st == (length $ currentText st) - 1+ then (length $ currentText st) - 1+ else cursorRow st + 1++ nextLine = currentText st !! (cursorRow st + 1)+ newCol = if cursorRow st == (length $ currentText st) - 1+ then cursorColumn st+ else if cursorColumn st <= length nextLine+ then cursorColumn st+ else length nextLine++ setEditCursorPosition wRef (newRow, newCol)+ 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+ let newRow = if cursorRow st == 0+ then 0+ else if cursorColumn st == 0+ then cursorRow st - 1+ else cursorRow st+ prevLine = currentText st !! (cursorRow st - 1)+ newCol = if cursorColumn st == 0+ then if cursorRow st == 0+ then 0+ else length prevLine+ else cursorColumn st - 1+ setEditCursorPosition wRef (newRow, newCol) 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+ curL <- getEditCurrentLine wRef+ let newRow = if cursorRow st == (length $ currentText st) - 1+ then cursorRow st+ else if cursorColumn st == length curL+ then cursorRow st + 1+ else cursorRow st+ newCol = if cursorColumn st == length curL+ then if cursorRow st == (length $ currentText st) - 1+ then cursorColumn st+ else 0+ else cursorColumn st + 1+ setEditCursorPosition wRef (newRow, newCol) 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+ curLine <- getEditCurrentLine wRef+ updateWidgetState wRef $ \st ->+ let newLine = inject (cursorColumn st) ch curLine+ newViewStart =+ if cursorColumn st == displayStart st + displayWidth st - 1+ then displayStart st + 1+ else displayStart st+ in st { displayStart = newViewStart+ , currentText = repl (cursorRow st) newLine (currentText st)+ }+ 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+ curLine <- getEditCurrentLine wRef+ case cursorColumn st < (length curLine) of+ True ->+ do+ let newLine = remove (cursorColumn st) curLine+ updateWidgetState wRef $ \s -> s { currentText = repl (cursorRow st) newLine (currentText st) }+ notifyChangeHandlers wRef+ False ->+ -- If we are on the last line, do nothing, but if we aren't,+ -- combine the next line with the current one+ if cursorRow st == (length $ currentText st) - 1+ then return ()+ else do+ let nextLine = currentText st !! (cursorRow st + 1)+ updateWidgetState wRef $ \s ->+ s { currentText = remove (cursorRow s + 1) $+ repl (cursorRow st) (curLine ++ nextLine) (currentText s)+ }
src/Graphics/Vty/Widgets/EventLoop.hs view
@@ -47,9 +47,7 @@ -- Create VTY event listener thread _ <- forkIO $ vtyEventListener vty eventChan - runUi' vty eventChan collection ctx `finally` do- reserve_display $ terminal vty- shutdown vty+ runUi' vty eventChan collection ctx `finally` shutdown vty vtyEventListener :: Vty -> TChan CombinedEvent -> IO () vtyEventListener vty chan =
src/Graphics/Vty/Widgets/Fills.hs view
@@ -20,9 +20,8 @@ -- specified character and attribute. vFill :: Char -> IO (Widget VFill) vFill c = do- wRef <- newWidget $ \w ->- w { state = VFill c- , growVertical_ = const $ return True+ wRef <- newWidget (VFill c) $ \w ->+ w { growVertical_ = const $ return True , render_ = \this s ctx -> do foc <- focused <~ this VFill ch <- getState this@@ -40,9 +39,8 @@ -- one row high, using the specified character and attribute. hFill :: Char -> Int -> IO (Widget HFill) hFill c h = do- wRef <- newWidget $ \w ->- w { state = HFill c h- , growHorizontal_ = const $ return True+ wRef <- newWidget (HFill c h) $ \w ->+ w { growHorizontal_ = const $ return True , render_ = \this s ctx -> do foc <- focused <~ this HFill ch height <- getState this
src/Graphics/Vty/Widgets/Fixed.hs view
@@ -31,17 +31,17 @@ -- |Impose a fixed horizontal size, in columns, on a 'Widget'. hFixed :: (Show a) => Int -> Widget a -> IO (Widget (HFixed a)) hFixed fixedWidth child = do- wRef <- newWidget $ \w ->- w { state = HFixed fixedWidth child- , render_ = \this s ctx -> do+ let initSt = HFixed fixedWidth child+ wRef <- newWidget initSt $ \w ->+ w { 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))+ (toEnum width - image_width img)+ (image_height img)) else img return img' @@ -62,9 +62,9 @@ -- |Impose a fixed vertical size, in columns, on a 'Widget'. vFixed :: (Show a) => Int -> Widget a -> IO (Widget (VFixed a)) vFixed maxHeight child = do- wRef <- newWidget $ \w ->- w { state = VFixed maxHeight child- , growHorizontal_ = const $ growHorizontal child+ let initSt = VFixed maxHeight child+ wRef <- newWidget initSt $ \w ->+ w { growHorizontal_ = const $ growHorizontal child , render_ = \this s ctx -> do VFixed height ch <- getState this@@ -73,8 +73,8 @@ -- 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))+ (image_width img)+ (toEnum height - image_height img)) else img return img'
src/Graphics/Vty/Widgets/Group.hs view
@@ -31,12 +31,11 @@ -- |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_ =+ let initSt = Group { entries = []+ , currentEntryNum = -1+ }+ wRef <- newWidget initSt $ \w ->+ w { getCursorPosition_ = \this -> getCursorPosition =<< currentEntry this
src/Graphics/Vty/Widgets/Limits.hs view
@@ -33,9 +33,9 @@ -- |Impose a maximum horizontal size, in columns, on a 'Widget'. hLimit :: (Show a) => Int -> Widget a -> IO (Widget (HLimit a)) hLimit maxWidth child = do- wRef <- newWidget $ \w ->- w { state = HLimit maxWidth child- , growHorizontal_ = const $ return False+ let initSt = HLimit maxWidth child+ wRef <- newWidget initSt $ \w ->+ w { growHorizontal_ = const $ return False , growVertical_ = const $ growVertical child , render_ = \this s ctx -> do HLimit width ch <- getState this@@ -59,9 +59,9 @@ -- |Impose a maximum vertical size, in columns, on a 'Widget'. vLimit :: (Show a) => Int -> Widget a -> IO (Widget (VLimit a)) vLimit maxHeight child = do- wRef <- newWidget $ \w ->- w { state = VLimit maxHeight child- , growHorizontal_ = const $ growHorizontal child+ let initSt = VLimit maxHeight child+ wRef <- newWidget initSt $ \w ->+ w { growHorizontal_ = const $ growHorizontal child , growVertical_ = const $ return False , render_ = \this s ctx -> do
src/Graphics/Vty/Widgets/List.hs view
@@ -42,6 +42,7 @@ import Data.Typeable import Control.Exception hiding (Handler) import Control.Monad+import qualified Data.Vector as V import Graphics.Vty import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Text@@ -87,21 +88,21 @@ -- /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+data List a b = List { selectedUnfocusedAttr :: !Attr+ , selectedIndex :: !Int -- ^The currently selected list index.- , scrollTopIndex :: Int+ , scrollTopIndex :: !Int -- ^The start index of the window of visible list -- items.- , scrollWindowSize :: Int+ , scrollWindowSize :: !Int -- ^The size of the window of visible list items.- , listItems :: [ListItem a b]+ , listItems :: V.Vector (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+ , itemHeight :: !Int } instance Show (List a b) where@@ -110,7 +111,7 @@ , ", selectedIndex = ", show $ selectedIndex lst , ", scrollTopIndex = ", show $ scrollTopIndex lst , ", scrollWindowSize = ", show $ scrollWindowSize lst- , ", listItems = <", show $ length $ listItems lst, " items>"+ , ", listItems = <", show $ V.length $ listItems lst, " items>" , ", itemHeight = ", show $ itemHeight lst , " }" ]@@ -127,7 +128,7 @@ , selectedIndex = -1 , scrollTopIndex = 0 , scrollWindowSize = 0- , listItems = []+ , listItems = V.empty , selectionChangeHandlers = schs , itemAddHandlers = iahs , itemRemoveHandlers = irhs@@ -137,7 +138,7 @@ -- |Get the length of the list in elements. getListSize :: Widget (List a b) -> IO Int-getListSize = ((length . listItems) <~~)+getListSize = ((V.length . listItems) <~~) -- |Remove an element from the list at the specified position. May -- throw 'BadItemIndex'.@@ -146,14 +147,14 @@ st <- getState list foc <- focused <~ list - let numItems = length $ listItems st+ let numItems = V.length $ listItems st oldScr = scrollTopIndex st when (pos < 0 || pos >= numItems) $ throw $ BadItemIndex pos -- Get the item from the list.- let (label, w) = listItems st !! pos+ let (label, w) = (listItems st) V.! pos sel = selectedIndex st newScrollTop = if pos <= oldScr@@ -178,8 +179,8 @@ else sel updateWidgetState list $ \s -> s { selectedIndex = newSelectedIndex- , listItems = take pos (listItems st) ++- drop (pos + 1) (listItems st)+ , listItems = V.take pos (listItems st) V.+++ V.drop (pos + 1) (listItems st) , scrollTopIndex = newScrollTop } @@ -212,14 +213,14 @@ -- 'newList'. addToList :: (Show b) => Widget (List a b) -> a -> Widget b -> IO () addToList list key w = do- numItems <- (length . listItems) <~~ list+ numItems <- (V.length . listItems) <~~ list insertIntoList list key w numItems -- |Insert an element into the list at the specified position. If the -- position exceeds the length of the list, it is inserted at the end. insertIntoList :: (Show b) => Widget (List a b) -> a -> Widget b -> Int -> IO () insertIntoList list key w pos = do- numItems <- (length . listItems) <~~ list+ numItems <- (V.length . listItems) <~~ list v <- growVertical w when (v) $ throw BadListWidgetSizePolicy@@ -253,8 +254,16 @@ else oldScr else oldScr + let vInject atPos a as = let (hd, t) = (V.take atPos as, V.drop atPos as)+ in hd V.++ (V.cons a t)++ -- Optimize the append case.+ let newItems s = if pos >= numItems+ then V.snoc (listItems s) (key, w)+ else vInject pos (key, w) (listItems s)+ updateWidgetState list $ \s -> s { itemHeight = h- , listItems = inject pos (key, w) (listItems s)+ , listItems = V.force $ newItems s , selectedIndex = newSelIndex , scrollTopIndex = newScrollTop }@@ -291,7 +300,7 @@ -- which happens when the user presses Enter on a selected element -- while the list has the focus. onItemActivated :: Widget (List a b)- -> (ActivateItemEvent a b -> IO ()) -> IO ()+ -> (ActivateItemEvent a b -> IO ()) -> IO () onItemActivated = addHandler (itemActivateHandlers <~~) -- |Clear the list, removing all elements. Does not invoke any@@ -301,7 +310,7 @@ updateWidgetState w $ \l -> l { selectedIndex = (-1) , scrollTopIndex = 0- , listItems = []+ , listItems = V.empty } -- |Create a new list using the specified attribute for the@@ -311,9 +320,8 @@ -> IO (Widget (List a b)) newList selAttr = do list <- newListData selAttr- wRef <- newWidget $ \w ->- w { state = list- , keyEventHandler = listKeyEvent+ wRef <- newWidget list $ \w ->+ w { keyEventHandler = listKeyEvent , growVertical_ = const $ return True , growHorizontal_ = const $ return True@@ -441,15 +449,15 @@ list <- state <~ wRef case selectedIndex list of (-1) -> return Nothing- i -> return $ Just (i, (listItems list) !! i)+ i -> return $ Just (i, (listItems list) V.! i) -- |Get the list item at the specified position. getListItem :: Widget (List a b) -> Int -> IO (Maybe (ListItem a b)) getListItem wRef pos = do list <- state <~ wRef- case pos >= 0 && pos < (length $ listItems list) of+ case pos >= 0 && pos < (V.length $ listItems list) of False -> return Nothing- True -> return $ Just ((listItems list) !! pos)+ True -> return $ Just ((listItems list) V.! pos) -- |Set the currently-selected list index. setSelected :: Widget (List a b) -> Int -> IO ()@@ -516,7 +524,7 @@ scrollBy' :: Int -> List a b -> List a b scrollBy' amount list = let sel = selectedIndex list- lastPos = (length $ listItems list) - 1+ lastPos = (V.length $ listItems list) - 1 validPositions = [0..lastPos] newPosition = sel + amount @@ -527,7 +535,7 @@ else 0 bottomPosition = min (scrollTopIndex list + scrollWindowSize list - 1)- ((length $ listItems list) - 1)+ ((V.length $ listItems list) - 1) topPosition = scrollTopIndex list windowPositions = [topPosition..bottomPosition] @@ -588,6 +596,6 @@ getVisibleItems_ list = let start = scrollTopIndex list stop = scrollTopIndex list + scrollWindowSize list- adjustedStop = (min stop $ length $ listItems list) - 1- in [ (listItems list !! i, i == selectedIndex list)+ adjustedStop = (min stop $ V.length $ listItems list) - 1+ in [ (listItems list V.! i, i == selectedIndex list) | i <- [start..adjustedStop] ]
src/Graphics/Vty/Widgets/Padding.hs view
@@ -105,10 +105,9 @@ -- |Create a 'Padded' wrapper to add padding. padded :: (Show a) => Widget a -> Padding -> IO (Widget Padded) padded ch padding = do- wRef <- newWidget $ \w ->- w { state = Padded ch padding-- , growVertical_ = const $ growVertical ch+ let initSt = Padded ch padding+ wRef <- newWidget initSt $ \w ->+ w { growVertical_ = const $ growVertical ch , growHorizontal_ = const $ growHorizontal ch , render_ =
src/Graphics/Vty/Widgets/ProgressBar.hs view
@@ -1,68 +1,116 @@ -- |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.+-- progress value between 0 and 100 inclusive and supports a text+-- label. Use the 'schedule' function to modify the progress bar's+-- state from a thread. module Graphics.Vty.Widgets.ProgressBar ( ProgressBar , newProgressBar- , progressBarWidget , setProgress+ , setProgressTextAlignment+ , setProgressText , 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+import Graphics.Vty.Widgets.Text+import Graphics.Vty.Widgets.Alignment -data ProgressBar = ProgressBar { progressBarWidget :: Widget (Box HFill HFill)- -- ^Get the widget of a progress bar.- , progressBarAmount :: IORef Int+data ProgressBar = ProgressBar { progressBarAmount :: Int , onChangeHandlers :: Handlers Int+ , progressBarText :: String+ , progressBarTextAlignment :: Alignment } +instance Show ProgressBar where+ show p = concat [ "ProgressBar { "+ , ", " ++ (show $ progressBarAmount p)+ , ", ... }"+ ]+ -- |Create a new progress bar with the specified completed and--- uncompleted colors, respectively.-newProgressBar :: Color -> Color -> IO ProgressBar-newProgressBar completeColor incompleteColor = do- let completeAttr = completeColor `on` completeColor- incompleteAttr = incompleteColor `on` incompleteColor+-- uncompleted attributes, respectively. The foreground of the+-- attributes will be used to show the progress bar's label, if any.+newProgressBar :: Attr -> Attr -> IO (Widget ProgressBar)+newProgressBar completeAttr incompleteAttr = do+ chs <- newHandlers+ t <- plainText ""+ let initSt = ProgressBar 0 chs "" AlignCenter+ wRef <- newWidget initSt $ \w ->+ w { growHorizontal_ = const $ return True+ , render_ =+ \this size ctx -> do+ -- Divide the available width according to the+ -- progress value+ prog <- progressBarAmount <~~ this+ txt <- progressBarText <~~ this+ al <- progressBarTextAlignment <~~ this - 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+ let complete_width = fromEnum $ (toRational prog / toRational (100.0 :: Double)) *+ (toRational $ fromEnum $ region_width size) + full_width = fromEnum $ region_width size+ full_str = take full_width $ mkStr txt al++ mkStr s AlignLeft = s ++ replicate (full_width - length txt) ' '+ mkStr s AlignRight = replicate (full_width - length txt) ' ' ++ s+ mkStr s AlignCenter = concat [ half+ , s+ , half+ , if length half * 2 < (full_width + length txt)+ then " "+ else ""+ ]+ where+ half = replicate ((full_width - length txt) `div` 2) ' '++ (complete_str, incomplete_str) = ( take complete_width full_str+ , drop complete_width full_str+ )++ setTextWithAttrs t [ (complete_str, completeAttr)+ , (incomplete_str, incompleteAttr)+ ]+ render t size ctx+ }++ setProgress wRef 0+ return wRef+ -- |Register a handler to be invoked when the progress bar's progress -- value changes. The handler will be passed the new progress value.-onProgressChange :: ProgressBar -> (Int -> IO ()) -> IO ()-onProgressChange = addHandler (return . onChangeHandlers)+onProgressChange :: Widget ProgressBar -> (Int -> IO ()) -> IO ()+onProgressChange = addHandler (onChangeHandlers <~~) -- |Set the progress bar's progress value. Values outside the allowed -- range will be ignored.-setProgress :: ProgressBar -> Int -> IO ()+setProgress :: Widget ProgressBar -> Int -> IO () setProgress p amt = when (amt >= 0 && amt <= 100) $ do- liftIO $ writeIORef (progressBarAmount p) amt- setBoxChildSizePolicy (progressBarWidget p) $ Percentage amt- fireEvent p (return . onChangeHandlers) amt+ updateWidgetState p $ \st -> st { progressBarAmount = amt }+ fireEvent p (onChangeHandlers <~~) amt +-- |Set the progress bar's text label alignment.+setProgressTextAlignment :: Widget ProgressBar -> Alignment -> IO ()+setProgressTextAlignment p al =+ updateWidgetState p $ \st -> st { progressBarTextAlignment = al }++-- |Set the progress bar's text label.+setProgressText :: Widget ProgressBar -> String -> IO ()+setProgressText p s =+ updateWidgetState p $ \st -> st { progressBarText = s }+ -- |Get the progress bar's current progress value.-getProgress :: ProgressBar -> IO Int-getProgress = liftIO . readIORef . progressBarAmount+getProgress :: Widget ProgressBar -> IO Int+getProgress = (progressBarAmount <~~) -- |Add a delta value to the progress bar's current value.-addProgress :: ProgressBar -> Int -> IO ()+addProgress :: Widget ProgressBar -> Int -> IO () addProgress p amt = do cur <- getProgress p let newAmt = cur + amt
src/Graphics/Vty/Widgets/Table.hs view
@@ -12,8 +12,6 @@ , RowLike(..) , TableError(..) , ColumnSpec(..)- , Alignment(..)- , Alignable(..) , (.|.) , newTable , setDefaultCellAlignment@@ -44,6 +42,7 @@ import Graphics.Vty.Widgets.Util import Graphics.Vty.Widgets.Fills import Graphics.Vty.Widgets.Box+import Graphics.Vty.Widgets.Alignment data TableError = ColumnCountMismatch -- ^A row added to the table did not have the same@@ -58,14 +57,6 @@ 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@@ -221,17 +212,17 @@ -> BorderStyle -> IO (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- }+ let initSt = Table { rows = []+ , columnSpecs = specs+ , borderStyle = borderSty+ , numColumns = length specs+ , borderAttr = def_attr+ , defaultCellAlignment = AlignLeft+ , defaultCellPadding = padNone+ } - , growHorizontal_ = \st -> do+ t <- newWidget initSt $ \w ->+ w { growHorizontal_ = \st -> do return $ any (== ColAuto) (map columnSize $ columnSpecs st) , render_ =
src/Graphics/Vty/Widgets/Text.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns #-} -- |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@@ -24,8 +24,8 @@ ) where +import Control.Applicative import Data.Monoid-import Data.Word import Graphics.Vty import Graphics.Vty.Widgets.Core import Text.Trans.Tokenize@@ -54,8 +54,8 @@ -- and the formatter used to apply attributes to the text. data FormattedText = FormattedText { text :: TextStream Attr- , formatter :: Formatter- , useFocusAttribute :: Bool+ , formatter :: !Formatter+ , useFocusAttribute :: !Bool } instance Show FormattedText where@@ -94,12 +94,13 @@ -- given here (and, depending on the formatter, order might matter). textWidget :: Formatter -> String -> IO (Widget FormattedText) textWidget format s = do- wRef <- newWidget $ \w ->- w { state = FormattedText { text = TS []- , formatter = format- , useFocusAttribute = False- }- , getCursorPosition_ = const $ return Nothing+ let initSt = FormattedText { text = TS []+ , formatter = format+ , useFocusAttribute = False+ }++ wRef <- newWidget initSt $ \w ->+ w { getCursorPosition_ = const $ return Nothing , render_ = \this size ctx -> do ft <- getState this@@ -166,10 +167,23 @@ ] lineImgs = map mkLineImg ls+ lineLength l = length $ tokenStr <$> l+ maxLineLength = maximum $ lineLength <$> ls+ emptyLineLength = min (fromEnum $ region_width sz) maxLineLength+ ls = map truncLine $ map (map entityToken) $ findLines newText truncLine = truncateLine (fromEnum $ region_width sz)++ -- When building images for empty lines, it's critical that we+ -- *don't* use the empty_image, because that will cause empty+ -- lines to collapse vertically. Instead, we create line images+ -- using spaces. When doing this it's important to make them as+ -- wide as the rest of the text because otherwise we could have+ -- weird-looking results with background attributes not+ -- affecting the whole empty line. We compute the length of the+ -- longest line above and use that to build the 'empty' lines. mkLineImg line = if null line- then char_fill attr' ' ' (region_width sz) (1::Word)+ then char_fill attr' ' ' emptyLineLength 1 else horiz_cat $ map mkTokenImg line nullImg = string def_attr ""
src/Graphics/Vty/Widgets/Util.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} module Graphics.Vty.Widgets.Util ( on , fgColor@@ -85,8 +86,8 @@ 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)+inject !pos !a !as = let (h, t) = (take pos as, drop pos as)+ in h ++ (a:t) repl :: Int -> a -> [a] -> [a]-repl pos a as = inject pos a (remove pos as)+repl !pos !a !as = inject pos a (remove pos as)
src/ListDemo.hs view
@@ -8,58 +8,68 @@ data AppElements = AppElements { theList :: Widget (List String FormattedText) , theBody :: Widget FormattedText- , theFooter1 :: Widget FormattedText- , theFooter2 :: Widget FormattedText- , theEdit :: Widget Edit+ , theFooter :: Widget FormattedText , 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+bodyAttr = white `on` black selAttr = black `on` yellow-hlAttr1 = red `on` black-hlAttr2 = yellow `on` black+keyAttr = fgColor magenta -uiCore appst w = do- (hBorder >>= withBorderAttribute titleAttr)- <--> w- <--> (hBorder >>= withBorderAttribute titleAttr)- <--> (return $ theEdit appst)- <--> ((return $ theFooter1 appst)- <++> (return $ theFooter2 appst)- <++> (hBorder >>= withBorderAttribute titleAttr))+message1 :: String+message1 = "This demonstration shows how list widgets behave. \n\+ \See the keystrokes below to try the demo." -buildUi1 appst = do- uiCore appst (return $ theList appst)+message2 :: [(String, Attr)]+message2 = [ ("- Press ", def_attr), ("q", keyAttr), (" to quit\n", def_attr)+ , ("- Press ", def_attr), ("+", keyAttr)+ , (" / ", def_attr), ("a", keyAttr)+ , (" to add a list item\n", def_attr)+ , ("- Press ", def_attr), ("-", keyAttr)+ , (" / ", def_attr), ("d", keyAttr)+ , (" to remove the selected list item\n", def_attr)+ , ("- Press ", def_attr)+ , ("up", keyAttr), (" / ", def_attr)+ , ("down", keyAttr), (" / ", def_attr)+ , ("page up", keyAttr), (" / ", def_attr)+ , ("page down", keyAttr)+ , (" to navigate the list\n", def_attr)+ ] -buildUi2 appst =- uiCore appst ((return $ theListLimit appst)- <--> (hBorder >>= withBorderAttribute titleAttr)- <--> (return $ theBody appst)- <--> (vFill ' '))+buildUi appst = do+ msg1 <- plainText message1+ setTextFormatter msg1 wrap --- Construct the application state using the message map.+ msg2 <- plainTextWithAttrs message2+ setTextFormatter msg2 wrap++ mainUi <- (hBorder >>= withBorderAttribute titleAttr)+ <--> (return $ theList appst)+ <--> ((return $ theFooter appst)+ <++> (hBorder >>= withBorderAttribute titleAttr))++ centered =<< hLimit 55 =<<+ ((return msg1)+ <--> ((vLimit 25 mainUi >>= bordered)+ <--> return msg2 >>= withBoxSpacing 1)+ >>= withBoxSpacing 1)++-- Construct the application statea 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+ ft <- plainText "" >>= withNormalAttribute titleAttr ll <- vLimit 5 lw c <- newCollection return $ AppElements { theList = lw , theBody = b- , theFooter1 = f1- , theFooter2 = f2- , theEdit = e+ , theFooter = ft , theListLimit = ll , uis = c }@@ -74,86 +84,40 @@ 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 ++ "]")+ Nothing -> "0/0"+ Just (i, _) -> (show $ i + 1) ++ "/" ++ (show sz)+ setText (theFooter st) msg 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- s <- getEditText e- addToList (theList st) s =<< plainText s- setEditText e ""+ ui <- buildUi st+ fg <- newFocusGroup - let doBodyUpdate (SelectionOn i _ _) = updateBody st i- doBodyUpdate SelectionOff = return ()+ _ <- addToCollection (uis st) ui fg+ _ <- addToFocusGroup fg (theList st) - (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 + let removeCurrentItem = do+ result <- getSelected (theList st)+ case result of+ Nothing -> return ()+ Just (i, _) -> removeFromList (theList st) i >> return ()+ addNewItem = do+ addToList (theList st) "unused" =<< plainText "a list item"+ (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+ (KASCII '-') -> removeCurrentItem >> return True+ (KASCII 'd') -> removeCurrentItem >> return True+ (KASCII '+') -> addNewItem >> return True+ (KASCII 'a') -> addNewItem >> return True _ -> return False-- setEditText (theEdit st) "edit me"- focus (theEdit st) -- We need to call these handlers manually because while they will -- be called automatically as items are added to the list in the
src/PhoneInputDemo.hs view
@@ -37,10 +37,6 @@ (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
+ src/ProgressBarDemo.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-missing-signatures #-}+module Main where++import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forever)++import System.Exit ( exitSuccess )+import Graphics.Vty+import Graphics.Vty.Widgets.All++-- Visual attributes.+focAttr = black `on` green+bodyAttr = bright_green `on` black+completeAttr = white `on` red+incompleteAttr = red `on` white++setupProgessBar :: IO (Widget ProgressBar)+setupProgessBar = do+ pb <- newProgressBar completeAttr incompleteAttr+ setProgressTextAlignment pb AlignCenter++ pb `onProgressChange` \val ->+ setProgressText pb $ "Progress (" ++ show val ++ " %)"++ return pb++setupProgressBarThread :: Widget ProgressBar -> IO ()+setupProgressBarThread pb = do+ forkIO $ forever $ do+ let act i = do+ threadDelay $ 1 * 1000 * 1000+ schedule $ setProgress pb (i `mod` 101)+ act $ i + 4+ act 0+ return ()++setupDialog :: (Show a) => Widget a -> IO (Dialog, Widget FocusGroup)+setupDialog ui = do+ (dlg, fg) <- newDialog ui "Progress Bar Demo"+ dlg `onDialogAccept` const exitSuccess+ dlg `onDialogCancel` const exitSuccess+ return (dlg, fg)++main :: IO ()+main = do+ pb <- setupProgessBar+ setupProgressBarThread pb++ (dlg, dlgFg) <- setupDialog pb++ c <- newCollection+ _ <- addToCollection c (dialogWidget dlg) dlgFg++ runUi c $ defaultContext { normalAttr = bodyAttr+ , focusAttr = focAttr+ }
src/Text/Trans/Tokenize.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-} -- |This module provides functionality for tokenizing text streams to -- differentiate between printed characters and structural elements -- such as newlines. Once tokenized, such text streams can be@@ -37,21 +37,21 @@ -- type of token should have as its contents a string of characters -- all of the same type. Tokens are generalized over an attribute -- type which can be used to annotate each token.-data Token a = S { tokenStr :: String+data Token a = S { tokenStr :: !String -- ^The token's string.- , tokenAttr :: a+ , tokenAttr :: !a -- ^The token's attribute. } -- ^Non-whitespace tokens.- | WS { tokenStr :: String+ | WS { tokenStr :: !String -- ^The token's string.- , tokenAttr :: a+ , tokenAttr :: !a -- ^The token's attribute. } -- ^Whitespace tokens. -- |A text stream entity is either a token or a structural element.-data TextStreamEntity a = T (Token a)+data TextStreamEntity a = T !(Token a) -- ^Constructor for ordinary tokens. | NL -- ^Newline.@@ -59,7 +59,7 @@ -- |A text stream is a list of text stream entities. A text stream -- |combines structural elements of the text (e.g., newlines) with the -- |text itself (words, whitespace, etc.).-data TextStream a = TS [TextStreamEntity a]+data TextStream a = TS ![TextStreamEntity a] instance (Show a) => Show (TextStream a) where show (TS ts) = "TS " ++ show ts
vty-ui.cabal view
@@ -1,5 +1,5 @@ Name: vty-ui-Version: 1.4+Version: 1.5 Synopsis: An interactive terminal user interface library for Vty @@ -12,7 +12,7 @@ having to worry about terminal size. . Be sure to check out the user manual for the version you're using- at: <http://codevine.org/vty-ui/>+ at: <http://jtdaugherty.github.com/vty-ui/> . Build with the 'demos' flag to get a set of demonstration programs to see some of the things the library can do!@@ -24,7 +24,7 @@ License: BSD3 License-File: LICENSE Cabal-Version: >= 1.6-Homepage: http://codevine.org/vty-ui/+Homepage: http://jtdaugherty.github.com/vty-ui/ Data-Files: doc/ch1/api_notes.tex@@ -90,17 +90,19 @@ containers >= 0.2 && < 0.5, regex-base >= 0.93 && < 0.94, directory >= 1.0 && < 1.2,- filepath >= 1.1 && < 1.3,+ filepath >= 1.1 && < 1.4, unix >= 2.4 && < 2.6, mtl >= 2.0 && < 2.1, stm >= 2.1 && < 2.3,- array >= 0.3 && < 0.4+ array >= 0.3.0.0 && < 0.5.0.0,+ vector >= 0.9 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: Graphics.Vty.Widgets.All+ Graphics.Vty.Widgets.Alignment Graphics.Vty.Widgets.Text Graphics.Vty.Widgets.Core Graphics.Vty.Widgets.Box@@ -159,6 +161,19 @@ if !flag(demos) Buildable: False +Executable vty-ui-progressbar-demo+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Main-is: ProgressBarDemo.hs+ if os(darwin)+ Extra-Lib-Dirs: /usr/lib+ Build-Depends:+ base >= 4 && < 5,+ mtl >= 2.0 && < 2.1,+ vty >= 4.6 && < 4.8+ if !flag(demos)+ Buildable: False+ Executable vty-ui-complex-demo Hs-Source-Dirs: src GHC-Options: -Wall@@ -169,7 +184,7 @@ base >= 4 && < 5, mtl >= 2.0 && < 2.1, bytestring >= 0.9 && < 1.0,- time >= 1.1 && < 1.3,+ time >= 1.1 && < 1.5, old-locale >= 1.0 && < 1.1, vty >= 4.6 && < 4.8 if !flag(demos)@@ -205,6 +220,19 @@ 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.8+ if !flag(demos)+ Buildable: False++Executable vty-ui-edit-demo+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Main-is: EditDemo.hs if os(darwin) Extra-Lib-Dirs: /usr/lib Build-Depends: