diff --git a/doc/ch3/deferring_to_children.tex b/doc/ch3/deferring_to_children.tex --- a/doc/ch3/deferring_to_children.tex +++ b/doc/ch3/deferring_to_children.tex @@ -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 diff --git a/doc/ch3/implementing_composite_widgets.tex b/doc/ch3/implementing_composite_widgets.tex --- a/doc/ch3/implementing_composite_widgets.tex +++ b/doc/ch3/implementing_composite_widgets.tex @@ -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 diff --git a/doc/ch3/implementing_event_handlers.tex b/doc/ch3/implementing_event_handlers.tex --- a/doc/ch3/implementing_event_handlers.tex +++ b/doc/ch3/implementing_event_handlers.tex @@ -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 diff --git a/doc/ch3/new_widget_type.tex b/doc/ch3/new_widget_type.tex --- a/doc/ch3/new_widget_type.tex +++ b/doc/ch3/new_widget_type.tex @@ -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 diff --git a/doc/ch4/Edit.tex b/doc/ch4/Edit.tex --- a/doc/ch4/Edit.tex +++ b/doc/ch4/Edit.tex @@ -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}). diff --git a/doc/ch4/ProgressBar.tex b/doc/ch4/ProgressBar.tex --- a/doc/ch4/ProgressBar.tex +++ b/doc/ch4/ProgressBar.tex @@ -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 diff --git a/doc/ch4/Table.tex b/doc/ch4/Table.tex --- a/doc/ch4/Table.tex +++ b/doc/ch4/Table.tex @@ -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: diff --git a/doc/macros.tex b/doc/macros.tex --- a/doc/macros.tex +++ b/doc/macros.tex @@ -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} diff --git a/src/ComplexDemo.hs b/src/ComplexDemo.hs --- a/src/ComplexDemo.hs +++ b/src/ComplexDemo.hs @@ -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) diff --git a/src/EditDemo.hs b/src/EditDemo.hs new file mode 100644 --- /dev/null +++ b/src/EditDemo.hs @@ -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 } diff --git a/src/Graphics/Vty/Widgets/Alignment.hs b/src/Graphics/Vty/Widgets/Alignment.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Alignment.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/All.hs b/src/Graphics/Vty/Widgets/All.hs --- a/src/Graphics/Vty/Widgets/All.hs +++ b/src/Graphics/Vty/Widgets/All.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Borders.hs b/src/Graphics/Vty/Widgets/Borders.hs --- a/src/Graphics/Vty/Widgets/Borders.hs +++ b/src/Graphics/Vty/Widgets/Borders.hs @@ -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 = diff --git a/src/Graphics/Vty/Widgets/Box.hs b/src/Graphics/Vty/Widgets/Box.hs --- a/src/Graphics/Vty/Widgets/Box.hs +++ b/src/Graphics/Vty/Widgets/Box.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Centering.hs b/src/Graphics/Vty/Widgets/Centering.hs --- a/src/Graphics/Vty/Widgets/Centering.hs +++ b/src/Graphics/Vty/Widgets/Centering.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/CheckBox.hs b/src/Graphics/Vty/Widgets/CheckBox.hs --- a/src/Graphics/Vty/Widgets/CheckBox.hs +++ b/src/Graphics/Vty/Widgets/CheckBox.hs @@ -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) diff --git a/src/Graphics/Vty/Widgets/Core.hs b/src/Graphics/Vty/Widgets/Core.hs --- a/src/Graphics/Vty/Widgets/Core.hs +++ b/src/Graphics/Vty/Widgets/Core.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Edit.hs b/src/Graphics/Vty/Widgets/Edit.hs --- a/src/Graphics/Vty/Widgets/Edit.hs +++ b/src/Graphics/Vty/Widgets/Edit.hs @@ -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) + } diff --git a/src/Graphics/Vty/Widgets/EventLoop.hs b/src/Graphics/Vty/Widgets/EventLoop.hs --- a/src/Graphics/Vty/Widgets/EventLoop.hs +++ b/src/Graphics/Vty/Widgets/EventLoop.hs @@ -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 = diff --git a/src/Graphics/Vty/Widgets/Fills.hs b/src/Graphics/Vty/Widgets/Fills.hs --- a/src/Graphics/Vty/Widgets/Fills.hs +++ b/src/Graphics/Vty/Widgets/Fills.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Fixed.hs b/src/Graphics/Vty/Widgets/Fixed.hs --- a/src/Graphics/Vty/Widgets/Fixed.hs +++ b/src/Graphics/Vty/Widgets/Fixed.hs @@ -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' diff --git a/src/Graphics/Vty/Widgets/Group.hs b/src/Graphics/Vty/Widgets/Group.hs --- a/src/Graphics/Vty/Widgets/Group.hs +++ b/src/Graphics/Vty/Widgets/Group.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Limits.hs b/src/Graphics/Vty/Widgets/Limits.hs --- a/src/Graphics/Vty/Widgets/Limits.hs +++ b/src/Graphics/Vty/Widgets/Limits.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/List.hs b/src/Graphics/Vty/Widgets/List.hs --- a/src/Graphics/Vty/Widgets/List.hs +++ b/src/Graphics/Vty/Widgets/List.hs @@ -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] ] diff --git a/src/Graphics/Vty/Widgets/Padding.hs b/src/Graphics/Vty/Widgets/Padding.hs --- a/src/Graphics/Vty/Widgets/Padding.hs +++ b/src/Graphics/Vty/Widgets/Padding.hs @@ -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_ = diff --git a/src/Graphics/Vty/Widgets/ProgressBar.hs b/src/Graphics/Vty/Widgets/ProgressBar.hs --- a/src/Graphics/Vty/Widgets/ProgressBar.hs +++ b/src/Graphics/Vty/Widgets/ProgressBar.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Table.hs b/src/Graphics/Vty/Widgets/Table.hs --- a/src/Graphics/Vty/Widgets/Table.hs +++ b/src/Graphics/Vty/Widgets/Table.hs @@ -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_ = diff --git a/src/Graphics/Vty/Widgets/Text.hs b/src/Graphics/Vty/Widgets/Text.hs --- a/src/Graphics/Vty/Widgets/Text.hs +++ b/src/Graphics/Vty/Widgets/Text.hs @@ -1,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 "" diff --git a/src/Graphics/Vty/Widgets/Util.hs b/src/Graphics/Vty/Widgets/Util.hs --- a/src/Graphics/Vty/Widgets/Util.hs +++ b/src/Graphics/Vty/Widgets/Util.hs @@ -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) diff --git a/src/ListDemo.hs b/src/ListDemo.hs --- a/src/ListDemo.hs +++ b/src/ListDemo.hs @@ -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 diff --git a/src/PhoneInputDemo.hs b/src/PhoneInputDemo.hs --- a/src/PhoneInputDemo.hs +++ b/src/PhoneInputDemo.hs @@ -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 diff --git a/src/ProgressBarDemo.hs b/src/ProgressBarDemo.hs new file mode 100644 --- /dev/null +++ b/src/ProgressBarDemo.hs @@ -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 + } diff --git a/src/Text/Trans/Tokenize.hs b/src/Text/Trans/Tokenize.hs --- a/src/Text/Trans/Tokenize.hs +++ b/src/Text/Trans/Tokenize.hs @@ -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 diff --git a/vty-ui.cabal b/vty-ui.cabal --- a/vty-ui.cabal +++ b/vty-ui.cabal @@ -1,5 +1,5 @@ Name: vty-ui -Version: 1.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: + at: . 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: