diff --git a/demos/CollectionDemo.hs b/demos/CollectionDemo.hs --- a/demos/CollectionDemo.hs +++ b/demos/CollectionDemo.hs @@ -25,7 +25,8 @@ mkSecondUI = do fg <- newFocusGroup - lst <- newTextList (green `on` blue) items 1 + lst <- newTextList items 1 + setSelectedUnfocusedAttr lst $ Just (green `on` blue) addToFocusGroup fg lst c <- centered =<< vLimit 10 =<< hLimit 50 =<< bordered lst return (c, fg) @@ -60,7 +61,7 @@ let keyHandler nextUI = \_ k mods -> case (k, mods) of - (KASCII 'n', [MCtrl]) -> nextUI >> return True + (KChar 'n', [MCtrl]) -> nextUI >> return True (KEsc, []) -> exitSuccess _ -> return False diff --git a/demos/ComplexDemo.hs b/demos/ComplexDemo.hs --- a/demos/ComplexDemo.hs +++ b/demos/ComplexDemo.hs @@ -16,7 +16,7 @@ fg = white bg = black focAttr = black `on` yellow -headerAttr = fgColor bright_green +headerAttr = fgColor brightGreen msgAttr = fgColor blue -- Multi-state checkbox value type @@ -64,7 +64,8 @@ edit1Header <- textWidget wrap T.empty >>= withNormalAttribute headerAttr edit2Header <- textWidget wrap T.empty >>= withNormalAttribute headerAttr - lst <- newList (fgColor bright_green) 1 + lst <- newList 1 + setSelectedUnfocusedAttr lst $ Just (fgColor brightGreen) selector <- vLimit 3 lst listHeader <- plainText T.empty diff --git a/demos/EditDemo.hs b/demos/EditDemo.hs --- a/demos/EditDemo.hs +++ b/demos/EditDemo.hs @@ -10,15 +10,19 @@ e2 <- multiLineEditWidget setEditLineLimit e2 $ Just 3 e3 <- editWidget + e4 <- editWidget + setEditRewriter e4 (const '*') fg <- newFocusGroup _ <- addToFocusGroup fg e1 _ <- addToFocusGroup fg e2 _ <- addToFocusGroup fg e3 + _ <- addToFocusGroup fg e4 be1 <- bordered =<< boxFixed 40 5 e1 be2 <- bordered =<< boxFixed 40 3 e2 be3 <- bordered =<< boxFixed 40 1 e3 + be4 <- bordered =<< boxFixed 40 1 e4 c <- centered =<< ((plainText "Multi-Line Editor (unlimited lines):") <--> (return be1) @@ -26,6 +30,8 @@ <--> (return be2) <--> (plainText "Single-Line Editor:") <--> (return be3) + <--> (plainText "Password input:") + <--> (return be4) <--> (plainText "- Esc to quit\n\n- TAB to switch editors") >>= withBoxSpacing 1 ) diff --git a/demos/ListDemo.hs b/demos/ListDemo.hs --- a/demos/ListDemo.hs +++ b/demos/ListDemo.hs @@ -11,11 +11,10 @@ AppElements { theList :: Widget (List T.Text FormattedText) , theBody :: Widget FormattedText , theFooter :: Widget FormattedText - , theListLimit :: Widget (VLimit (List T.Text FormattedText)) , uis :: Collection } -titleAttr = bright_white `on` blue +titleAttr = brightWhite `on` blue focAttr = black `on` green bodyAttr = white `on` black selAttr = black `on` yellow @@ -26,19 +25,19 @@ \See the keystrokes below to try the demo." message2 :: [(T.Text, 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) +message2 = [ ("- Press ", defAttr), ("q", keyAttr), (" to quit\n", defAttr) + , ("- Press ", defAttr), ("+", keyAttr) + , (" / ", defAttr), ("a", keyAttr) + , (" to add a list item\n", defAttr) + , ("- Press ", defAttr), ("-", keyAttr) + , (" / ", defAttr), ("d", keyAttr) + , (" to remove the selected list item\n", defAttr) + , ("- Press ", defAttr) + , ("up", keyAttr), (" / ", defAttr) + , ("down", keyAttr), (" / ", defAttr) + , ("page up", keyAttr), (" / ", defAttr) , ("page down", keyAttr) - , (" to navigate the list\n", def_attr) + , (" to navigate the list\n", defAttr) ] buildUi appst = do @@ -62,17 +61,16 @@ -- Construct the application statea using the message map. mkAppElements :: IO AppElements mkAppElements = do - lw <- newTextList selAttr [] 1 + lw <- newTextList [] 1 + setSelectedUnfocusedAttr lw $ Just selAttr b <- textWidget wrap T.empty ft <- plainText T.empty >>= withNormalAttribute titleAttr - ll <- vLimit 5 lw c <- newCollection return $ AppElements { theList = lw , theBody = b , theFooter = ft - , theListLimit = ll , uis = c } @@ -115,11 +113,11 @@ (theList st) `onKeyPressed` \_ k _ -> do case k of - (KASCII 'q') -> exitSuccess - (KASCII '-') -> removeCurrentItem >> return True - (KASCII 'd') -> removeCurrentItem >> return True - (KASCII '+') -> addNewItem >> return True - (KASCII 'a') -> addNewItem >> return True + (KChar 'q') -> exitSuccess + (KChar '-') -> removeCurrentItem >> return True + (KChar 'd') -> removeCurrentItem >> return True + (KChar '+') -> addNewItem >> return True + (KChar 'a') -> addNewItem >> return True _ -> return False -- We need to call these handlers manually because while they will diff --git a/demos/ProgressBarDemo.hs b/demos/ProgressBarDemo.hs --- a/demos/ProgressBarDemo.hs +++ b/demos/ProgressBarDemo.hs @@ -12,7 +12,7 @@ -- Visual attributes. focAttr = black `on` green -bodyAttr = bright_green `on` black +bodyAttr = brightGreen `on` black completeAttr = white `on` red incompleteAttr = red `on` white diff --git a/doc/ch2/event_loop.tex b/doc/ch2/event_loop.tex --- a/doc/ch2/event_loop.tex +++ b/doc/ch2/event_loop.tex @@ -137,7 +137,7 @@ \fw{someAttr `withStyle` underline} & adding a style \\ \hline \end{tabular} -The Vty \fw{def\_attr} value's default configuration is used as a +The Vty \fw{defAttr} value's default configuration is used as a basis for all partially-specified attributes. The functions described above are defined in the \fw{Util} module. diff --git a/doc/ch2/focus_groups.tex b/doc/ch2/focus_groups.tex --- a/doc/ch2/focus_groups.tex +++ b/doc/ch2/focus_groups.tex @@ -68,7 +68,7 @@ \begin{haskellcode} fg <- newFocusGroup fg `onKeyPressed` \_ key _ -> - if key == KASCII 'q' then + if key == KChar 'q' then exitSuccess else return False \end{haskellcode} diff --git a/doc/ch2/handling_user_input.tex b/doc/ch2/handling_user_input.tex --- a/doc/ch2/handling_user_input.tex +++ b/doc/ch2/handling_user_input.tex @@ -28,12 +28,12 @@ \begin{haskellcode} w `onKeyPressed` \_ key _ -> - if key == KASCII 'f' then + if key == KChar 'f' then (launchTheMissiles >> return True) else return False w `onKeyPressed` \_ key _ -> - if key == KASCII 'q' then + if key == KChar 'q' then exitSuccess else return False \end{haskellcode} 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 @@ -41,16 +41,15 @@ \begin{haskellcode} let st = Counter initialValue - wRef <- newWidget st $ \w -> ... + 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\_}. We call \fw{newWidget}'s result \fw{wRef} because -it is a reference to a widget, and this helps distinguish it from the -actual widget data in the next step. +as \fw{render\_}. The \fw{newWidget} function will return the +\fw{IORef} as \fw{Widget Counter}; \fw{Widget} is a type alias. The \fw{newWidget} function takes an initial state of the widget (of type \fw{a}) and a transformation function \fw{WidgetImpl a -> @@ -67,7 +66,7 @@ \this size ctx -> do (Counter v) <- getState this let s = T.pack $ show v - width = (fromEnum $ region_width size) - + width = (fromEnum $ regionWidth size) - (fromEnum $ textWidth s) (truncated, _, _) = clip1d (Phys 0) (Phys width) s return $ string (getNormalAttr ctx) $ T.unpack truncated @@ -117,7 +116,7 @@ \begin{haskellcode} let s = T.pack $ show v - width = (fromEnum $ region_width size) - + width = (fromEnum $ regionWidth size) - (fromEnum $ textWidth s) (truncated, _, _) = clip1d (Phys 0) (Phys width) s \end{haskellcode} diff --git a/doc/ch3/rendering.tex b/doc/ch3/rendering.tex --- a/doc/ch3/rendering.tex +++ b/doc/ch3/rendering.tex @@ -21,7 +21,7 @@ specified attribute. \item \fw{char} -- Creates an image from a character using the specified attribute. -\item \fw{char\_fill} -- Creates an image with the specified width and +\item \fw{charFill} -- Creates an image with the specified width and height, filled with the specified character and attribute. \item \fw{<->} -- Vertical concatenation of images. \item \fw{<|>} -- Horizontal concatenation of images. diff --git a/doc/ch3/widgetimpl_api.tex b/doc/ch3/widgetimpl_api.tex --- a/doc/ch3/widgetimpl_api.tex +++ b/doc/ch3/widgetimpl_api.tex @@ -54,10 +54,10 @@ Sometimes used when positioning child widgets and when positioning the cursor, if any. \item \fw{normalAttribute} -- the widget's normal attribute. Defaults - to Vty's \fw{def\_attr} value, which merges transparently with the + to Vty's \fw{defAttr} value, which merges transparently with the \fw{RenderContext}'s normal attribute. \item \fw{focusAttribute} -- the widget's focus attribute. Defaults - to Vty's \fw{def\_attr} value, which merges transparently with the + to Vty's \fw{defAttr} value, which merges transparently with the \fw{RenderContext}'s focus attribute. \item \fw{keyEventHandler} -- the action responsible for handling key events for this widget. The default implementation merely starts diff --git a/doc/ch4/Fixed.tex b/doc/ch4/Fixed.tex --- a/doc/ch4/Fixed.tex +++ b/doc/ch4/Fixed.tex @@ -51,7 +51,7 @@ guarantee that the specified space is consumed. \begin{haskellcode} - lst <- newList (green `on` black) 1 + lst <- newList 1 ui <- vFixed 5 lst \end{haskellcode} diff --git a/doc/ch4/FormattedText.tex b/doc/ch4/FormattedText.tex --- a/doc/ch4/FormattedText.tex +++ b/doc/ch4/FormattedText.tex @@ -9,7 +9,7 @@ \fw{plainText} function and can be laid out in the usual way: \begin{haskellcode} - t1 <- plainText "blue" >>= withNormalAttribute (fgColor blue) + t1 <- plainText "blue" >>= withNormal (fgColor blue) t2 <- plainText "green" >>= withNormalAttribute (fgColor green) ui <- (return t1) <++> (return t2) \end{haskellcode} @@ -28,7 +28,7 @@ All text widget update functions \textit{tokenize} their inputs, finding contiguous sequences of whitespace and non-whitespace characters and newlines, and store the list of tokens in the widget. -Each token is assigned a default attribute of \fw{def\_attr}, which +Each token is assigned a default attribute of \fw{defAttr}, which defaults to the ``normal'' attribute of the widget (see Section \ref{sec:attributes} for more information on attributes). @@ -48,9 +48,9 @@ \begin{haskellcode} t <- plainText "" setTextWithAttrs t [ ("foo", fgColor green) - , (" ", def_attr) + , (" ", defAttr) , ("bar", fgColor yellow) - , (" ", def_attr) + , (" ", defAttr) , ("baz", red `on` blue) ] \end{haskellcode} diff --git a/doc/ch4/List.tex b/doc/ch4/List.tex --- a/doc/ch4/List.tex +++ b/doc/ch4/List.tex @@ -36,16 +36,21 @@ Lists are created with the \fw{newList} function: \begin{haskellcode} - lst <- newList attr 1 + lst <- newList 1 \end{haskellcode} -\fw{newList} takes two parameters: the attribute of the currently-selected item -to be used when the list is \textit{not} focused, and the height, in rows, of -each widget in the list. The \fw{List} uses its own focus attribute (Section +\fw{newList} takes one parameter: the height, in rows, of each widget in the +list. The \fw{List} uses its own focus attribute (Section \ref{sec:attributes}) as the attribute of the currently-selected item when it has the focus. The widget type of the list (\fw{b} above) won't be chosen by the type system until you actually add something to the list. +The \fw{List} widget uses the default focus attribute of the rendering context +to render the selected item when the list has the focus. To control how the +selected item appears when the list has or lacks focus, use see +\fw{set\-Selected\-Focused\-Attr} and +\fw{set\-Se\-lec\-ted\-Un\-fo\-cused\-Attr}. + Items may be added to a \fw{List} with the \fw{addToList} function, which takes an internal value (e.g., \fw{String}) and a widget of the appropriate type: @@ -110,7 +115,7 @@ value, and widget of the currently-selected list item. \item \fw{getListItem} -- takes a \fw{Widget (List a b)} and an index and returns \fw{Nothing} if the \fw{List} has no item at the - specified index item or returns \fw{Just (pos, (val, widget))} + specified index item or returns \fw{Just (val, widget)} corresponding to the list index. \end{itemize} diff --git a/doc/macros.tex b/doc/macros.tex --- a/doc/macros.tex +++ b/doc/macros.tex @@ -1,6 +1,6 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.7.1} +\newcommand{\vtyuiversion}{1.8} \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}} 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 @@ -71,7 +71,7 @@ -- attribute and character. hBorder :: IO (Widget HBorder) hBorder = do - let initSt = HBorder def_attr T.empty + let initSt = HBorder defAttr T.empty wRef <- newWidget initSt $ \w -> w { growHorizontal_ = const $ return True , render_ = renderHBorder @@ -80,8 +80,8 @@ return wRef renderHBorder :: Widget HBorder -> DisplayRegion -> RenderContext -> IO Image -renderHBorder _ (DisplayRegion 0 _) _ = return empty_image -renderHBorder _ (DisplayRegion _ 0) _ = return empty_image +renderHBorder _ (0, _) _ = return emptyImage +renderHBorder _ (_, 0) _ = return emptyImage renderHBorder this s ctx = do HBorder attr str <- getState this let attr' = mergeAttrs [ overrideAttr ctx @@ -89,7 +89,7 @@ , normalAttr ctx ] ch = skinHorizontal $ skin ctx - noTitle = T.pack $ replicate (fromEnum $ region_width s) ch + noTitle = T.pack $ replicate (fromEnum $ regionWidth s) ch wStr <- case T.null str of True -> return noTitle @@ -98,10 +98,10 @@ , str , T.pack " " ] - case (textWidth title) > (Phys $ fromEnum $ region_width s) of + case (textWidth title) > (Phys $ fromEnum $ regionWidth s) of True -> return noTitle False -> do - let remaining = (Phys $ fromEnum $ region_width s) - (textWidth title) + let remaining = (Phys $ fromEnum $ regionWidth s) - (textWidth title) Phys side1 = remaining `div` Phys 2 side2 = if remaining `mod` Phys 2 == Phys 0 then side1 else side1 + 1 return $ T.concat [ T.pack $ replicate side1 ch @@ -123,7 +123,7 @@ -- attribute and character. vBorder :: IO (Widget VBorder) vBorder = do - let initSt = VBorder def_attr + let initSt = VBorder defAttr wRef <- newWidget initSt $ \w -> w { growVertical_ = const $ return True , getCursorPosition_ = const $ return Nothing @@ -133,7 +133,7 @@ , attr , normalAttr ctx ] - return $ char_fill attr' (skinVertical $ skin ctx) 1 (region_height s) + return $ charFill attr' (skinVertical $ skin ctx) 1 (regionHeight s) } return wRef @@ -154,7 +154,7 @@ -- |Wrap a widget in a bordering box. bordered :: (Show a) => Widget a -> IO (Widget (Bordered a)) bordered child = do - let initSt = Bordered def_attr child T.empty + let initSt = Bordered defAttr child T.empty wRef <- newWidget initSt $ \w -> w { growVertical_ = const $ growVertical child , growHorizontal_ = const $ growHorizontal child @@ -182,7 +182,7 @@ drawBordered :: (Show a) => Bordered a -> DisplayRegion -> RenderContext -> IO Image drawBordered this s ctx - | region_width s < 2 || region_height s < 2 = return empty_image + | regionWidth s < 2 || regionHeight s < 2 = return emptyImage | otherwise = do let Bordered attr child label = this attr' = mergeAttrs [ overrideAttr ctx @@ -194,12 +194,13 @@ -- Render the contained widget with enough room to draw borders. -- Then, use the size of the rendered widget to constrain the space -- used by the (expanding) borders. - let constrained = DisplayRegion (region_width s - 2) (region_height s - 2) + let constrained = (regionWidth s - 2, regionHeight s - 2) childImage <- render child constrained ctx - let adjusted = DisplayRegion (image_width childImage + 2) - (image_height childImage) + let adjusted = ( imageWidth childImage + 2 + , imageHeight childImage + ) tlCorner <- plainText (T.singleton $ skinCornerTL sk) >>= withNormalAttribute attr' @@ -225,6 +226,6 @@ leftRight <- render vb adjusted ctx - let middle = horiz_cat [leftRight, childImage, leftRight] + let middle = horizCat [leftRight, childImage, leftRight] - return $ vert_cat [top, middle, bottom] + return $ vertCat [top, middle, bottom] 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 @@ -28,7 +28,6 @@ ) where -import GHC.Word ( Word ) import Data.Typeable import Control.Exception import Control.Monad @@ -81,11 +80,11 @@ -- growth comparison function , secondGrows :: IO Bool -- region dimension fetch function - , regDimension :: DisplayRegion -> Word + , regDimension :: DisplayRegion -> Int -- image dimension fetch function - , imgDimension :: Image -> Word + , imgDimension :: Image -> Int -- dimension modification function - , withDimension :: DisplayRegion -> Word -> DisplayRegion + , withDimension :: DisplayRegion -> Int -> DisplayRegion -- Oriented image concatenation , img_cat :: [Image] -> Image } @@ -145,13 +144,13 @@ , secondGrows = (if o == Vertical then growVertical else growHorizontal) wb , regDimension = - if o == Vertical then region_height else region_width + if o == Vertical then snd else fst , imgDimension = - if o == Vertical then image_height else image_width + if o == Vertical then imageHeight else imageWidth , withDimension = if o == Vertical then withHeight else withWidth , img_cat = - if o == Vertical then vert_cat else horiz_cat + if o == Vertical then vertCat else horizCat } wRef <- newWidget initSt $ \w -> @@ -209,9 +208,9 @@ setCurrentPosition (boxFirst b) pos case boxOrientation b of Horizontal -> setCurrentPosition (boxSecond b) $ - pos `plusWidth` ((region_width ch1_size) + (toEnum $ boxSpacing b)) + pos `plusWidth` ((fst ch1_size) + (toEnum $ boxSpacing b)) Vertical -> setCurrentPosition (boxSecond b) $ - pos `plusHeight` ((region_height ch1_size) + (toEnum $ boxSpacing b)) + pos `plusHeight` ((snd ch1_size) + (toEnum $ boxSpacing b)) } wRef `relayFocusEvents` wa @@ -290,34 +289,34 @@ let spAttr = getNormalAttr ctx spacing = boxSpacing this spacer = case spacing of - 0 -> empty_image + 0 -> emptyImage _ -> case boxOrientation this of - Horizontal -> let h = max (image_height img1) (image_height img2) - in char_fill spAttr ' ' (toEnum spacing) h - Vertical -> let w = max (image_width img1) (image_width img2) - in char_fill spAttr ' ' w (toEnum spacing) + Horizontal -> let h = max (imageHeight img1) (imageHeight img2) + in charFill spAttr ' ' (toEnum spacing) h + Vertical -> let w = max (imageWidth img1) (imageWidth img2) + in charFill spAttr ' ' w (toEnum spacing) -- Use the larger of the two images to determine padding in the -- opposite dimension. E.g. if this is a vertical box, we want -- to pad the images such that they have the same width. common_opposite_dim = case boxOrientation this of - Horizontal -> max (image_height img1) (image_height img2) - Vertical -> max (image_width img1) (image_width img2) + Horizontal -> max (imageHeight img1) (imageHeight img2) + Vertical -> max (imageWidth img1) (imageWidth img2) padded_img1 = case boxOrientation this of Horizontal -> img1 <-> - (char_fill spAttr ' ' (image_width img1) - (common_opposite_dim - image_height img1)) + (charFill spAttr ' ' (imageWidth img1) + (common_opposite_dim - imageHeight img1)) Vertical -> img1 <|> - (char_fill spAttr ' ' (common_opposite_dim - image_width img1) - (image_height img1)) + (charFill spAttr ' ' (common_opposite_dim - imageWidth img1) + (imageHeight img1)) padded_img2 = case boxOrientation this of Horizontal -> img2 <-> - (char_fill spAttr ' ' (image_width img2) - (common_opposite_dim - image_height img2)) + (charFill spAttr ' ' (imageWidth img2) + (common_opposite_dim - imageHeight img2)) Vertical -> img2 <|> - (char_fill spAttr ' ' (common_opposite_dim - image_width img2) - (image_height img2)) + (charFill spAttr ' ' (common_opposite_dim - imageWidth img2) + (imageHeight img2)) return $ (img_cat this) [padded_img1, spacer, padded_img2] @@ -333,7 +332,7 @@ -- If the box is too large to fit in the available space (since it -- has fixed dimensions and can't be scaled), return the empty -- image. - | toEnum firstDim + toEnum secondDim > regDimension this s = return (empty_image, empty_image) + | toEnum firstDim + toEnum secondDim > regDimension this s = return (emptyImage, emptyImage) | otherwise = do let withDim = withDimension this img1 <- render (boxFirst this) (s `withDim` (toEnum firstDim)) ctx @@ -341,8 +340,8 @@ -- pad the images so they fill the space appropriately. let fill img amt = case boxOrientation this of - Vertical -> char_fill (getNormalAttr ctx) ' ' (image_width img) amt - Horizontal -> char_fill (getNormalAttr ctx) ' ' amt (image_height img) + Vertical -> charFill (getNormalAttr ctx) ' ' (imageWidth img) amt + Horizontal -> charFill (getNormalAttr ctx) ' ' amt (imageHeight img) firstDimW = toEnum firstDim secondDimW = toEnum secondDim img1_size = (imgDimension this) img1 @@ -380,7 +379,7 @@ b_img <- render b s' ctx return $ if renderDimension a_img >= regDim actualSpace - then [a_img, empty_image] + then [a_img, emptyImage] else [a_img, b_img] renderHalves = do 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 @@ -11,7 +11,6 @@ ) where -import GHC.Word ( Word ) import Graphics.Vty.Widgets.Core import Graphics.Vty import Graphics.Vty.Widgets.Util @@ -34,12 +33,12 @@ img <- render child s ctx let attr' = getNormalAttr ctx - (half, half') = centered_halves region_width s (image_width img) + (half, half') = centered_halves regionWidth s (imageWidth img) return $ if half > 0 - then horiz_cat [ char_fill attr' ' ' half (image_height img) + then horizCat [ charFill attr' ' ' half (imageHeight img) , img - , char_fill attr' ' ' half' (image_height img) + , charFill attr' ' ' half' (imageHeight img) ] else img @@ -48,7 +47,7 @@ HCentered child <- getState this s <- getCurrentSize this chSz <- getCurrentSize child - let (half, _) = centered_halves region_width s (region_width chSz) + let (half, _) = centered_halves regionWidth s (regionWidth chSz) chPos = pos `plusWidth` half setCurrentPosition child chPos @@ -77,12 +76,12 @@ img <- render child s ctx let attr' = getNormalAttr ctx - (half, half') = centered_halves region_height s (image_height img) + (half, half') = centered_halves regionHeight s (imageHeight img) return $ if half > 0 - then vert_cat [ char_fill attr' ' ' (image_width img) half + then vertCat [ charFill attr' ' ' (imageWidth img) half , img - , char_fill attr' ' ' (image_width img) half' + , charFill attr' ' ' (imageWidth img) half' ] else img @@ -91,7 +90,7 @@ VCentered child <- getState this s <- getCurrentSize this chSz <- getCurrentSize child - let (half, _) = centered_halves region_height s (region_height chSz) + let (half, _) = centered_halves regionHeight s (regionHeight chSz) chPos = pos `plusHeight` half setCurrentPosition child chPos @@ -107,7 +106,7 @@ centered :: (Show a) => Widget a -> IO (Widget (VCentered (HCentered a))) centered wRef = vCentered =<< hCentered wRef -centered_halves :: (DisplayRegion -> Word) -> DisplayRegion -> Word -> (Word, Word) +centered_halves :: (DisplayRegion -> Int) -> DisplayRegion -> Int -> (Int, Int) centered_halves region_size s obj_sz = let remaining = region_size s - obj_sz half = remaining `div` 2 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 @@ -236,7 +236,7 @@ getCheckboxLabel = (checkboxLabel <~~) radioKeyEvent :: (Eq a) => Widget (CheckBox a) -> Key -> [Modifier] -> IO Bool -radioKeyEvent this (KASCII ' ') [] = cycleCheckbox this >> return True +radioKeyEvent this (KChar ' ') [] = cycleCheckbox this >> return True radioKeyEvent this KEnter [] = cycleCheckbox this >> return True radioKeyEvent _ _ _ = return False 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 @@ -137,7 +137,7 @@ , overrideAttr :: Attr -- ^An override attribute to be used to override -- both the normal and focus attributes in effect - -- during rendering. Usually def_attr, this + -- during rendering. Usually defAttr, this -- attribute is used when child widgets need to have -- their attributes overridden by a parent widget. , skin :: Skin @@ -152,7 +152,7 @@ -- |Default context settings. defaultContext :: RenderContext -defaultContext = RenderContext def_attr (white `on` blue) def_attr unicodeSkin +defaultContext = RenderContext defAttr (white `on` blue) defAttr unicodeSkin -- |The type of widget implementations, parameterized on the type of -- the widget's state. @@ -276,10 +276,10 @@ v <- visible <~ wRef case v of - False -> return empty_image + False -> return emptyImage True -> do -- Merge the override attributes with the context. If the - -- overrides haven't been set (still def_attr), they will + -- overrides haven't been set (still defAttr), they will -- have no effect on the context attributes. norm <- normalAttribute <~ wRef foc <- focusAttribute <~ wRef @@ -288,12 +288,13 @@ } img <- render_ impl wRef sz newCtx - let imgsz = DisplayRegion (image_width img) (image_height img) + let imgsz = (imageWidth img, imageHeight img) - when (image_width img > region_width sz || - image_height img > region_height sz) $ throw $ ImageTooBig (show impl) sz imgsz + when ((imageWidth img > 0 && imageHeight img > 0) && + (imageWidth img > regionWidth sz || imageHeight img > regionHeight sz)) $ + throw $ ImageTooBig (show impl) sz imgsz - setCurrentSize wRef $ DisplayRegion (image_width img) (image_height img) + setCurrentSize wRef (imageWidth img, imageHeight img) return img -- |Render a widget and set its position after rendering is complete. @@ -352,12 +353,12 @@ wRef <- newIORef $ WidgetImpl { state = initState - , render_ = \_ _ _ -> return empty_image + , render_ = \_ _ _ -> return emptyImage , growVertical_ = const $ return False , growHorizontal_ = const $ return False , setCurrentPosition_ = \_ _ -> return () - , currentSize = DisplayRegion 0 0 - , currentPosition = DisplayRegion 0 0 + , currentSize = (0, 0) + , currentPosition = (0, 0) , focused = False , visible = True , gainFocusHandlers = gfhs @@ -365,8 +366,8 @@ , loseFocusHandlers = lfhs , keyEventHandler = \_ _ _ -> return False , getCursorPosition_ = defaultCursorInfo - , normalAttribute = def_attr - , focusAttribute = def_attr + , normalAttribute = defAttr + , focusAttribute = defAttr } updateWidget wRef f @@ -375,10 +376,10 @@ -- |Default cursor positioning implementation used by 'newWidget'. defaultCursorInfo :: Widget a -> IO (Maybe DisplayRegion) defaultCursorInfo w = do - sz <- getCurrentSize w + (rW, _) <- getCurrentSize w pos <- getCurrentPosition w - if region_width sz > 0 then - return $ Just $ pos `plusWidth` (region_width sz - 1) else + if rW > 0 then + return $ Just $ pos `plusWidth` (rW - 1) else return Nothing -- |Given a widget and key event information, invoke the widget's key @@ -545,7 +546,7 @@ let initSt = FocusGroup { entries = [] , currentEntryNum = -1 - , nextKey = (KASCII '\t', []) + , nextKey = (KChar '\t', []) , prevKey = (KBackTab, []) } diff --git a/src/Graphics/Vty/Widgets/DirBrowser.hs b/src/Graphics/Vty/Widgets/DirBrowser.hs --- a/src/Graphics/Vty/Widgets/DirBrowser.hs +++ b/src/Graphics/Vty/Widgets/DirBrowser.hs @@ -137,7 +137,9 @@ <++> (return fileInfo) <++> (hFill ' ' 1) <++> (return errorText)) >>= withNormalAttribute (browserHeaderAttr bSkin) - l <- newList (browserUnfocusedSelAttr bSkin) 1 + l <- newList 1 + setSelectedUnfocusedAttr l $ Just (browserUnfocusedSelAttr bSkin) + ui <- vBox header =<< vBox l footer r <- newIORef "" @@ -231,7 +233,7 @@ [ (\_ s -> isRegularFile s , \_ s -> return $ T.pack $ "regular file, " ++ (show $ fileSize s) ++ " bytes" - , def_attr) + , defAttr) , (\_ s -> isSymbolicLink s, (\p stat -> do linkDest <- if not $ isSymbolicLink stat @@ -255,7 +257,7 @@ annotation = getAnnotation' fullPath st $ (browserCustomAnnotations sk) ++ (builtInAnnotations cur sk) - getAnnotation' _ _ [] = (def_attr, return T.empty) + getAnnotation' _ _ [] = (defAttr, return T.empty) getAnnotation' pth stat ((f,mkAnn,a):rest) = if f pth stat then (a, mkAnn pth stat) @@ -268,8 +270,8 @@ handleBrowserKey b _ KRight [] = descend b False >> return True handleBrowserKey b _ KLeft [] = ascend b >> return True handleBrowserKey b _ KEsc [] = cancelBrowse b >> return True -handleBrowserKey b _ (KASCII 'q') [] = cancelBrowse b >> return True -handleBrowserKey b _ (KASCII 'r') [] = refreshBrowser b >> return True +handleBrowserKey b _ (KChar 'q') [] = cancelBrowse b >> return True +handleBrowserKey b _ (KChar 'r') [] = refreshBrowser b >> return True handleBrowserKey _ _ _ _ = return False -- |Refresh the browser by reloading and displaying the contents of 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 @@ -41,6 +41,8 @@ , getEditText , getEditCurrentLine , setEditText + , setEditRewriter + , setCharFilter , getEditCursorPosition , setEditCursorPosition , setEditLineLimit @@ -76,6 +78,8 @@ , cursorMoveHandlers :: Handlers (Int, Int) , lineLimit :: Maybe Int , maxLength :: Maybe Int + , rewriter :: Char -> Char + , charFilter :: Char -> Bool } instance Show Edit where @@ -103,6 +107,8 @@ , cursorMoveHandlers = cmhs , lineLimit = Nothing , maxLength = Nothing + , rewriter = id + , charFilter = const True } wRef <- newWidget initSt $ \w -> @@ -128,15 +134,28 @@ let (cursorRow, _) = Z.cursorPosition (contents st) Phys offset = physCursorCol st - clipLeft (clipRect st) newPos = pos - `withWidth` (toEnum ((fromEnum $ region_width pos) + offset)) + `withWidth` (toEnum ((fromEnum $ regionWidth pos) + offset)) `plusHeight` (toEnum (cursorRow - (fromEnum $ clipTop $ clipRect st))) return $ if f then Just newPos else Nothing +-- |Set the function which rewrites all characters at rendering time. Defaults +-- to 'id'. Does not affect text stored in the editor. +setEditRewriter :: Widget Edit -> (Char -> Char) -> IO () +setEditRewriter w f = + updateWidgetState w $ \st -> st { rewriter = f } + +-- |Set the function which allows typed characters in the edit widget. +-- Defaults to 'const' 'True', allowing all characters. For example, setting the +-- filter to ('elem' \"0123456789\") will only allow numbers in the edit widget. +setCharFilter :: Widget Edit -> (Char -> Bool) -> IO () +setCharFilter w f = + updateWidgetState w $ \st -> st { charFilter = f } + renderEditWidget :: Widget Edit -> DisplayRegion -> RenderContext -> IO Image renderEditWidget this size ctx = do - resize this ( Phys $ fromEnum $ region_height size - , Phys $ fromEnum $ region_width size ) + resizeEdit this ( Phys $ fromEnum $ regionHeight size + , Phys $ fromEnum $ regionWidth size ) st <- getState this isFocused <- focused <~ this @@ -147,9 +166,10 @@ attr = if isFocused then focusAttr ctx else nAttr clipped = doClipping (Z.getText $ contents st) (clipRect st) + rewritten = ((rewriter st) <$>) <$> clipped - totalAllowedLines = fromEnum $ region_height size - numEmptyLines = lim - length clipped + totalAllowedLines = fromEnum $ regionHeight size + numEmptyLines = lim - length rewritten where lim = case lineLimit st of Just v -> min v totalAllowedLines @@ -158,9 +178,9 @@ emptyLines = replicate numEmptyLines "" lineWidget s = let Phys physLineLength = sum $ chWidth <$> s in string attr s <|> - char_fill attr ' ' (region_width size - toEnum physLineLength) 1 + charFill attr ' ' (regionWidth size - toEnum physLineLength) 1 - return $ vert_cat $ lineWidget <$> (clipped ++ emptyLines) + return $ vertCat $ lineWidget <$> (rewritten ++ emptyLines) doClipping :: [T.Text] -> ClipRect -> [String] doClipping ls rect = @@ -221,8 +241,8 @@ getEditMaxLength :: Widget Edit -> IO (Maybe Int) getEditMaxLength = (maxLength <~~) -resize :: Widget Edit -> (Phys, Phys) -> IO () -resize e (newHeight, newWidth) = do +resizeEdit :: Widget Edit -> (Phys, Phys) -> IO () +resizeEdit e (newHeight, newWidth) = do updateWidgetState e $ \st -> let newRect = (clipRect st) { clipHeight = newHeight , clipWidth = newWidth @@ -366,10 +386,10 @@ editKeyEvent this k mods = do let run f = applyEdit f this >> return True case (k, mods) of - (KASCII 'a', [MCtrl]) -> run Z.gotoBOL - (KASCII 'k', [MCtrl]) -> run Z.killToEOL - (KASCII 'e', [MCtrl]) -> run Z.gotoEOL - (KASCII 'd', [MCtrl]) -> run Z.deleteChar + (KChar 'a', [MCtrl]) -> run Z.gotoBOL + (KChar 'k', [MCtrl]) -> run Z.killToEOL + (KChar 'e', [MCtrl]) -> run Z.gotoEOL + (KChar 'd', [MCtrl]) -> run Z.deleteChar (KLeft, []) -> run Z.moveLeft (KRight, []) -> run Z.moveRight (KUp, []) -> run Z.moveUp @@ -389,7 +409,11 @@ else st return v (KDel, []) -> run Z.deleteChar - (KASCII ch, []) -> run (Z.insertChar ch) + (KChar ch, []) -> do + st <- getState this + if charFilter st ch + then run (Z.insertChar ch) + else return True -- True even if the filter rejected the character. (KHome, []) -> run Z.gotoBOL (KEnd, []) -> run Z.gotoEOL (KEnter, []) -> do 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 @@ -10,12 +10,16 @@ , shutdownUi , newCollection , addToCollection + , addToCollectionWithCallbacks , setCurrentEntry + , EntryHide + , EntryShow ) where import Data.IORef import Data.Typeable +import Data.Default (def) import Control.Concurrent ( forkIO ) import Control.Concurrent.STM ( atomically ) import Control.Concurrent.STM.TChan @@ -42,17 +46,18 @@ -- 'Collection' is empty. runUi :: Collection -> RenderContext -> IO () runUi collection ctx = do - vty <- mkVty + vty <- mkVty def -- Create VTY event listener thread _ <- forkIO $ vtyEventListener vty eventChan + setCurrentEntry collection 0 runUi' vty eventChan collection ctx `finally` shutdown vty vtyEventListener :: Vty -> TChan CombinedEvent -> IO () vtyEventListener vty chan = forever $ do - e <- next_event vty + e <- nextEvent vty atomically $ writeTChan chan $ VTYEvent e -- |Schedule a widget-mutating 'IO' action to be run by the main event @@ -68,20 +73,20 @@ runUi' :: Vty -> TChan CombinedEvent -> Collection -> RenderContext -> IO () runUi' vty chan collection ctx = do - sz <- display_bounds $ terminal vty + sz <- displayBounds $ outputIface vty e <- getCurrentEntry collection let fg = entryFocusGroup e - img <- entryRenderAndPosition e (DisplayRegion 0 0) sz ctx - update vty $ pic_for_image img + img <- entryRenderAndPosition e (0, 0) sz ctx + update vty $ picForLayers [img] mPos <- getCursorPosition fg case mPos of - Just (DisplayRegion w h) -> do - show_cursor $ terminal vty - set_cursor_pos (terminal vty) w h - Nothing -> hide_cursor $ terminal vty + Just (w, h) -> do + showCursor $ outputIface vty + setCursorPos (outputIface vty) w h + Nothing -> hideCursor $ outputIface vty -- Get the next event(s) in the queue. Returns all available events; -- blocks until at least one event is available. @@ -114,8 +119,16 @@ instance Exception CollectionError -data Entry = forall a. (Show a) => Entry (Widget a) (Widget FocusGroup) +type EntryShow = IO () +type EntryHide = IO () +data Entry = forall a. (Show a) => Entry + { entryWidget :: Widget a + , entryFocusGroup :: Widget FocusGroup + , entryShowCallback :: EntryShow + , entryHideCallback :: EntryHide + } + data CollectionData = CollectionData { entries :: [Entry] , currentEntryNum :: Int @@ -132,10 +145,7 @@ ] entryRenderAndPosition :: Entry -> DisplayRegion -> DisplayRegion -> RenderContext -> IO Image -entryRenderAndPosition (Entry w _) = renderAndPosition w - -entryFocusGroup :: Entry -> Widget FocusGroup -entryFocusGroup (Entry _ fg) = fg +entryRenderAndPosition (Entry { entryWidget = w }) = renderAndPosition w -- |Create a new collection. newCollection :: IO Collection @@ -144,24 +154,41 @@ , currentEntryNum = -1 } +getMaybeCurrentEntry :: Collection -> IO (Maybe Entry) +getMaybeCurrentEntry cRef = do + cur <- currentEntryNum <~ cRef + es <- entries <~ cRef + if cur == -1 + then return Nothing + else if cur >= 0 && cur < length es + then return . Just $ es !! cur + else return Nothing + getCurrentEntry :: Collection -> IO Entry getCurrentEntry cRef = do + maybeEntry <- getMaybeCurrentEntry cRef cur <- currentEntryNum <~ cRef - es <- entries <~ cRef - if cur == -1 then - throw $ BadCollectionIndex cur else - if cur >= 0 && cur < length es then - return $ es !! cur else - throw $ BadCollectionIndex cur + case maybeEntry of + Nothing -> throw $ BadCollectionIndex cur + Just entry -> return entry -- |Add a widget and its focus group to a collection. Returns an -- action which, when invoked, will switch to the interface specified -- in the call. addToCollection :: (Show a) => Collection -> Widget a -> Widget FocusGroup -> IO (IO ()) -addToCollection cRef wRef fg = do +addToCollection cRef wRef fg = addToCollectionWithCallbacks cRef wRef fg (return ()) (return ()) + +-- |Add a widget and its focus group to a collection. In addition, two +-- callbacks -- one to call when showing the widget and one to call when hiding +-- it (i.e. showing some other widget) -- must be provided. Returns an action +-- which, when invoked, will switch to the interface specified. +addToCollectionWithCallbacks :: (Show a) => Collection -> Widget a + -> Widget FocusGroup -> EntryShow + -> EntryHide -> IO (IO ()) +addToCollectionWithCallbacks cRef wRef fg onShowCb onHideCb = do i <- (length . entries) <~ cRef modifyIORef cRef $ \st -> - st { entries = (entries st) ++ [Entry wRef fg] + st { entries = (entries st) ++ [Entry wRef fg onShowCb onHideCb] , currentEntryNum = if currentEntryNum st == -1 then 0 else currentEntryNum st @@ -172,9 +199,18 @@ setCurrentEntry :: Collection -> Int -> IO () setCurrentEntry cRef i = do st <- readIORef cRef - if i < length (entries st) && i >= 0 then - (modifyIORef cRef $ \s -> s { currentEntryNum = i }) else - throw $ BadCollectionIndex i + if i < length (entries st) && i >= 0 + then do + -- Let the old entry know it's no longer current. + maybeOldEntry <- getMaybeCurrentEntry cRef + case maybeOldEntry of + Nothing -> return () + Just oldEntry -> entryHideCallback oldEntry + -- Set the current entry index. + (modifyIORef cRef $ \s -> s { currentEntryNum = i }) + else throw $ BadCollectionIndex i + e <- getCurrentEntry cRef + entryShowCallback e resetFocusGroup $ entryFocusGroup e 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 @@ -28,7 +28,7 @@ let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx , normalAttr ctx ] - return $ char_fill attr' ch (region_width s) (region_height s) + return $ charFill attr' ch (regionWidth s) (regionHeight s) , getCursorPosition_ = const $ return Nothing } @@ -50,7 +50,7 @@ let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx , normalAttr ctx ] - return $ char_fill attr' ch (region_width s) (toEnum height) + return $ charFill attr' ch (regionWidth s) (toEnum height) , getCursorPosition_ = const $ return Nothing } 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 @@ -35,12 +35,12 @@ 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)) + let region = s `withWidth` fromIntegral (min (toEnum width) (regionWidth 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) ' ' - (toEnum width - image_width img) + let img' = if imageWidth img < regionWidth region + then img <|> (charFill (getNormalAttr ctx) ' ' + (toEnum width - imageWidth img) 1) else img return img' @@ -72,13 +72,13 @@ , render_ = \this s ctx -> do VFixed height ch <- getState this - let region = s `withHeight` fromIntegral (min (toEnum height) (region_height s)) + let region = s `withHeight` fromIntegral (min (toEnum height) (regionHeight s)) img <- render ch region ctx -- Pad the image if it's smaller than the region. - let img' = if image_height img < region_height region - then img <-> (char_fill (getNormalAttr ctx) ' ' + let img' = if imageHeight img < regionHeight region + then img <-> (charFill (getNormalAttr ctx) ' ' 1 - (toEnum height - image_height img)) + (toEnum height - imageHeight 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 @@ -13,7 +13,7 @@ where import Control.Monad ( when ) -import Graphics.Vty ( empty_image ) +import Graphics.Vty ( emptyImage ) import Graphics.Vty.Widgets.Core -- |A group of widgets of a specified type. @@ -65,7 +65,7 @@ , render_ = \this sz ctx -> do cur <- currentEntryNum <~~ this case cur of - (-1) -> return empty_image + (-1) -> return emptyImage _ -> do e <- currentEntry this render e sz ctx 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 @@ -21,7 +21,6 @@ where import Control.Monad -import Graphics.Vty import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Util @@ -39,7 +38,7 @@ , growVertical_ = const $ growVertical child , render_ = \this s ctx -> do HLimit width ch <- getState this - let region = s `withWidth` fromIntegral (min (toEnum width) (region_width s)) + let region = s `withWidth` fromIntegral (min (toEnum width) (regionWidth s)) render ch region ctx , setCurrentPosition_ = @@ -70,7 +69,7 @@ , render_ = \this s ctx -> do VLimit height ch <- getState this - let region = s `withHeight` fromIntegral (min (toEnum height) (region_height s)) + let region = s `withHeight` fromIntegral (min (toEnum height) (regionHeight s)) render ch region ctx , setCurrentPosition_ = 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 @@ -19,6 +19,8 @@ , addToList , insertIntoList , removeFromList + , setSelectedFocusedAttr + , setSelectedUnfocusedAttr -- ** List manipulation , scrollBy , scrollUp @@ -92,7 +94,8 @@ -- /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 +data List a b = List { selectedUnfocusedAttr :: Maybe Attr + , selectedFocusedAttr :: Maybe Attr , selectedIndex :: !Int -- ^The currently selected list index. , scrollTopIndex :: !Int @@ -112,6 +115,7 @@ instance Show (List a b) where show lst = concat [ "List { " , "selectedUnfocusedAttr = ", show $ selectedUnfocusedAttr lst + , ", selectedFocusedAttr = ", show $ selectedFocusedAttr lst , ", selectedIndex = ", show $ selectedIndex lst , ", scrollTopIndex = ", show $ scrollTopIndex lst , ", scrollWindowSize = ", show $ scrollWindowSize lst @@ -120,16 +124,16 @@ , " }" ] -newListData :: Attr -- ^The attribute of the selected item - -> Int -- ^Item widget height in rows +newListData :: Int -- ^Item widget height in rows -> IO (List a b) -newListData selAttr h = do +newListData h = do schs <- newHandlers iahs <- newHandlers irhs <- newHandlers iacths <- newHandlers - return $ List { selectedUnfocusedAttr = selAttr + return $ List { selectedUnfocusedAttr = Nothing + , selectedFocusedAttr = Nothing , selectedIndex = -1 , scrollTopIndex = 0 , scrollWindowSize = 0 @@ -213,6 +217,18 @@ -- Return the removed item. return (label, w) +-- |Sets the attributes to be merged on the selected list item when the list +-- widget has the focus. +setSelectedFocusedAttr :: Widget (List a b) -> Maybe Attr -> IO () +setSelectedFocusedAttr w attr = do + updateWidgetState w $ \l -> l { selectedFocusedAttr = attr } + +-- |Sets the attributes to be merged on the selected list item when the list +-- widget does not have the focus. +setSelectedUnfocusedAttr :: Widget (List a b) -> Maybe Attr -> IO () +setSelectedUnfocusedAttr w attr = do + updateWidgetState w $ \l -> l { selectedUnfocusedAttr = attr } + -- |Add an item to the list. Its widget will be constructed from the -- specified internal value using the widget constructor passed to -- 'newList'. @@ -301,14 +317,13 @@ , listItems = V.empty } --- |Create a new list using the specified attribute for the --- currently-selected element when the list does NOT have focus. +-- |Create a new list. The list's item widgets will be rendered using the +-- specified height in rows. newList :: (Show b) => - Attr -- ^The attribute of the selected item - -> Int -- ^Height of list item widgets in rows + Int -- ^Height of list item widgets in rows -> IO (Widget (List a b)) -newList selAttr ht = do - list <- newListData selAttr ht +newList ht = do + list <- newListData ht wRef <- newWidget list $ \w -> w { keyEventHandler = listKeyEvent @@ -331,12 +346,9 @@ -- Resize the list based on the available space and the -- height of each item. when (h > 0) $ - resize this (max 1 ((fromEnum $ region_height sz) `div` h)) - - listData <- getState this - foc <- focused <~ this + resizeList this (max 1 ((fromEnum $ regionHeight sz) `div` h)) - renderListWidget foc listData sz ctx + renderListWidget this sz ctx , setCurrentPosition_ = \this pos -> do @@ -374,55 +386,55 @@ Nothing -> return False Just (_, (_, e)) -> handleKeyEvent e k mods -renderListWidget :: (Show b) => Bool -> List a b -> DisplayRegion -> RenderContext -> IO Image -renderListWidget foc list s ctx = do +renderListWidget :: (Show b) => Widget (List a b) -> DisplayRegion -> RenderContext -> IO Image +renderListWidget this s ctx = do + list <- getState this + foc <- focused <~ this + let items = map (\((_, w), sel) -> (w, sel)) $ getVisibleItems_ list + childSelFocAttr = (maybe (focusAttr ctx) id) $ selectedFocusedAttr list + childSelUnfocAttr = (maybe (focusAttr ctx) id) $ selectedUnfocusedAttr list defaultAttr = mergeAttrs [ overrideAttr ctx , normalAttr ctx ] renderVisible [] = return [] renderVisible ((w, sel):ws) = do - na <- normalAttribute <~ w let att = if sel then if foc - then focusAttr ctx - else mergeAttrs [ selectedUnfocusedAttr list - , defaultAttr - ] - else mergeAttrs [ na - , defaultAttr - ] + then mergeAttrs [ childSelFocAttr, defaultAttr ] + else mergeAttrs [ childSelUnfocAttr, defaultAttr ] + else defaultAttr + -- Height-limit the widget by wrapping it with a VFixed/VLimit limited <- vLimit (itemHeight list) =<< vFixed (itemHeight list) w img <- render limited s $ ctx { overrideAttr = att } - let actualHeight = min (region_height s) (toEnum $ itemHeight list) - img' = img <|> char_fill att ' ' - (region_width s - image_width img) + let actualHeight = min (regionHeight s) (toEnum $ itemHeight list) + img' = img <|> charFill att ' ' + (regionWidth s - imageWidth img) actualHeight imgs <- renderVisible ws return (img':imgs) - let filler = char_fill defaultAttr ' ' (region_width s) fill_height + let filler = charFill defaultAttr ' ' (regionWidth s) fill_height fill_height = if scrollWindowSize list == 0 - then region_height s + then regionHeight s else toEnum $ ((scrollWindowSize list - length items) * itemHeight list) visible_imgs <- renderVisible items - return $ vert_cat (visible_imgs ++ [filler]) + return $ vertCat (visible_imgs ++ [filler]) -- |A convenience function to create a new list using 'Text' values as -- the internal values and 'FormattedText' widgets to represent those -- strings. -newTextList :: Attr -- ^The attribute of the selected item - -> [T.Text] -- ^The list items +newTextList :: [T.Text] -- ^The list items -> Int -- ^Maximum number of rows of text to show per list item -> IO (Widget (List T.Text FormattedText)) -newTextList selAttr labels h = do - list <- newList selAttr h +newTextList labels h = do + list <- newList h forM_ labels $ \l -> (addToList list l =<< plainText l) return list @@ -480,8 +492,8 @@ where matcher = \(match, _) -> item == match -resize :: Widget (List a b) -> Int -> IO () -resize wRef newSize = do +resizeList :: Widget (List a b) -> Int -> IO () +resizeList wRef newSize = do when (newSize == 0) $ throw ResizeError size <- (scrollWindowSize . state) <~ wRef 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 @@ -19,7 +19,6 @@ ) where -import Data.Word import Data.Monoid import Graphics.Vty import Graphics.Vty.Widgets.Core @@ -53,16 +52,16 @@ instance Paddable Padding where pad p1 p2 = p1 +++ p2 -leftPadding :: Padding -> Word +leftPadding :: Padding -> Int leftPadding (Padding _ _ _ l) = toEnum l -rightPadding :: Padding -> Word +rightPadding :: Padding -> Int rightPadding (Padding _ r _ _) = toEnum r -bottomPadding :: Padding -> Word +bottomPadding :: Padding -> Int bottomPadding (Padding _ _ b _) = toEnum b -topPadding :: Padding -> Word +topPadding :: Padding -> Int topPadding (Padding t _ _ _) = toEnum t -- |Padding constructor with no padding. @@ -111,19 +110,21 @@ , growHorizontal_ = const $ growHorizontal ch , render_ = - \this sz ctx -> - if (region_width sz < 2) || (region_height sz < 2) - then return empty_image - else do - Padded child p <- getState this + \this sz ctx -> do + Padded child p <- getState this + + if (regionWidth sz < leftPadding p + rightPadding p) || + (regionHeight sz < bottomPadding p + topPadding p) then + return emptyImage else + do f <- focused <~ this -- Compute constrained space based on padding -- settings. let constrained = sz `withWidth` (toEnum $ max 0 newWidth) `withHeight` (toEnum $ max 0 newHeight) - newWidth = (fromEnum $ region_width sz) - fromEnum (leftPadding p + rightPadding p) - newHeight = (fromEnum $ region_height sz) - fromEnum (topPadding p + bottomPadding p) + newWidth = (fromEnum $ regionWidth sz) - fromEnum (leftPadding p + rightPadding p) + newHeight = (fromEnum $ regionHeight sz) - fromEnum (topPadding p + bottomPadding p) attr = mergeAttrs [ if f then focusAttr ctx else overrideAttr ctx , normalAttr ctx ] @@ -132,11 +133,11 @@ img <- render child constrained ctx -- Create padding images. - let leftImg = char_fill attr ' ' (leftPadding p) (image_height img) - rightImg = char_fill attr ' ' (rightPadding p) (image_height img) - topImg = char_fill attr ' ' (image_width img + leftPadding p + rightPadding p) + let leftImg = charFill attr ' ' (leftPadding p) (imageHeight img) + rightImg = charFill attr ' ' (rightPadding p) (imageHeight img) + topImg = charFill attr ' ' (imageWidth img + leftPadding p + rightPadding p) (topPadding p) - bottomImg = char_fill attr ' ' (image_width img + leftPadding p + rightPadding p) + bottomImg = charFill attr ' ' (imageWidth img + leftPadding p + rightPadding p) (bottomPadding p) return $ topImg <-> (leftImg <|> img <|> rightImg) <-> bottomImg 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 @@ -67,9 +67,9 @@ complete_width = Phys $ fromEnum $ (toRational prog / toRational (100.0 :: Double)) * - (toRational $ fromEnum $ region_width size) + (toRational $ fromEnum $ regionWidth size) - full_width = Phys $ fromEnum $ region_width size + full_width = Phys $ fromEnum $ regionWidth size full_str = truncateText full_width $ mkStr txt al mkStr s AlignLeft = 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 @@ -28,7 +28,6 @@ import Data.Monoid import qualified Data.Text as T import Data.Typeable -import Data.Word import Data.List import Control.Applicative hiding ((<|>)) import Control.Exception @@ -216,7 +215,7 @@ , columnSpecs = specs , borderStyle = borderSty , numColumns = length specs - , borderAttr = def_attr + , borderAttr = defAttr , defaultCellAlignment = AlignLeft , defaultCellPadding = padNone } @@ -238,21 +237,21 @@ sideBorderL <- mkSideBorder this ctx True sideBorderR <- mkSideBorder this ctx False - let body = vert_cat $ intersperse rowBorder rowImgs - withTBBorders = vert_cat [topBorder, body, bottomBorder] - withSideBorders = horiz_cat [sideBorderL, withTBBorders, sideBorderR] + let body = vertCat $ intersperse rowBorder rowImgs + withTBBorders = vertCat [topBorder, body, bottomBorder] + withSideBorders = horizCat [sideBorderL, withTBBorders, sideBorderR] -- Ideally, we would only display rows that we have room -- to render, but this is a much easier cop-out. :) - if ((region_width sz < image_width withSideBorders) || - (region_height sz < image_height withSideBorders)) then - return empty_image else + if ((regionWidth sz < imageWidth withSideBorders) || + (regionHeight sz < imageHeight withSideBorders)) then + return emptyImage else return withSideBorders , setCurrentPosition_ = \this pos -> do sz <- getCurrentSize this - if region_width sz == 0 || region_height sz == 0 then + if regionWidth sz == 0 || regionHeight sz == 0 then return () else do bs <- borderStyle <~~ this @@ -272,7 +271,7 @@ cellPhysSizes <- forM row $ \cell -> case cell of TableCell cw _ _ -> getCurrentSize cw - EmptyCell -> return $ DisplayRegion 0 1 + EmptyCell -> return (0, 1) -- Include 1 as a possible height to -- prevent zero-height images from @@ -280,7 +279,7 @@ -- won't hurt in the case where other -- cells are bigger, since their heights -- will be chosen instead. - let maxSize = maximum $ 1 : map region_height cellPhysSizes + let maxSize = maximum $ 1 : map regionHeight cellPhysSizes borderOffset = if rowBorders bs then 1 else 0 @@ -289,7 +288,7 @@ positionRow this bs rowPos row positionRows (height + maxSize + borderOffset) rest - positionRows (region_height pos + edgeOffset) rs + positionRows (regionHeight pos + edgeOffset) rs } return t @@ -322,7 +321,7 @@ bs <- borderStyle <~~ t if not $ rowBorders bs then - return empty_image else + return emptyImage else mkRowBorder_ t sz ctx intChar -- Make a row border that matches the width of each row but does not @@ -343,13 +342,13 @@ intersection = string bAttr' [intChar] imgs = (flip map) szs $ \s -> case s of - ColFixed n -> char_fill bAttr' (skinHorizontal sk) n 1 - ColAuto -> char_fill bAttr' (skinHorizontal sk) aw 1 + ColFixed n -> charFill bAttr' (skinHorizontal sk) n 1 + ColAuto -> charFill bAttr' (skinHorizontal sk) aw 1 imgs' = if colBorders bs then intersperse intersection imgs else imgs - return $ horiz_cat imgs' + return $ horizCat imgs' mkTopBottomBorder :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image mkTopBottomBorder t sz ctx intChar = do @@ -357,7 +356,7 @@ if edgeBorders bs then mkRowBorder_ t sz ctx intChar else - return empty_image + return emptyImage -- Make vertical side borders for the table, including row border -- intersections if necessary. @@ -367,7 +366,7 @@ if edgeBorders bs then mkSideBorder_ t ctx isLeft else - return empty_image + return emptyImage mkSideBorder_ :: Widget Table -> RenderContext -> Bool -> IO Image mkSideBorder_ t ctx isLeft = do @@ -396,16 +395,16 @@ rowHeights <- forM rs $ \(TableRow row) -> do hs <- forM row $ \cell -> case cell of - TableCell cw _ _ -> region_height <$> getCurrentSize cw + TableCell cw _ _ -> regionHeight <$> getCurrentSize cw EmptyCell -> return 1 return $ maximum hs - let borderImgs = (flip map) rowHeights $ \h -> char_fill bAttr' (skinVertical sk) 1 h + let borderImgs = (flip map) rowHeights $ \h -> charFill bAttr' (skinVertical sk) 1 h withIntersections = if rowBorders bs then intersperse intersection borderImgs else borderImgs - return $ vert_cat $ topCorner : withIntersections ++ [bottomCorner] + return $ vertCat $ topCorner : withIntersections ++ [bottomCorner] positionRow :: Widget Table -> BorderStyle -> DisplayRegion -> [TableCell] -> IO () positionRow t bs pos cells = do @@ -434,7 +433,7 @@ doPositioning 0 $ zip szs cells -autoWidth :: Widget Table -> DisplayRegion -> IO Word +autoWidth :: Widget Table -> DisplayRegion -> IO Int autoWidth t sz = do specs <- columnSpecs <~~ t bs <- borderStyle <~~ t @@ -448,7 +447,7 @@ edgeWidth = if edgeBorders bs then 2 else 0 colWidth = if colBorders bs then (toEnum $ length sizes - 1) else 0 - return $ toEnum ((max 0 ((fromEnum $ region_width sz) - totalFixed - edgeWidth - colWidth)) + return $ toEnum ((max 0 ((fromEnum $ regionWidth sz) - totalFixed - edgeWidth - colWidth)) `div` numAuto) -- |Add a heading row to a table. Adds a row using the specified @@ -543,8 +542,8 @@ rowBorders BorderFull = True rowBorders _ = False -rowHeight :: [Image] -> Word -rowHeight = maximum . map image_height +rowHeight :: [Image] -> Int +rowHeight = maximum . map imageHeight renderRow :: Widget Table -> DisplayRegion -> [TableCell] -> RenderContext -> IO Image renderRow tbl sz cells ctx = do @@ -563,7 +562,7 @@ cellImgs <- forM (zip cells sizes) $ \(cellW, sizeSpec) -> do - let cellSz = DisplayRegion cellWidth (region_height sz) + let cellSz = (cellWidth, regionHeight sz) cellWidth = case sizeSpec of ColFixed n -> toEnum n ColAuto -> aw @@ -571,16 +570,16 @@ img <- renderCell cellSz cellW $ ctx { normalAttr = newDefault } -- Right-pad the image if it isn't big enough to fill the -- cell. - case compare (image_width img) (region_width cellSz) of + case compare (imageWidth img) (regionWidth cellSz) of EQ -> return img - LT -> return $ img <|> char_fill att ' ' - (max 0 (region_width cellSz - image_width img)) - (max (image_height img) 1) + LT -> return $ img <|> charFill att ' ' + (max 0 (regionWidth cellSz - imageWidth img)) + (max (imageHeight img) 1) GT -> throw CellImageTooBig let maxHeight = rowHeight cellImgs cellImgsBottomPadded = (flip map) cellImgs $ \img -> - img <-> char_fill att ' ' (image_width img) (maxHeight - image_height img) + img <-> charFill att ' ' (imageWidth img) (maxHeight - imageHeight img) -- If we need to draw borders in between columns, do that. let bAttr' = mergeAttrs [ overrideAttr ctx @@ -589,6 +588,6 @@ ] withBorders = case colBorders borderSty of False -> cellImgsBottomPadded - True -> intersperse (char_fill bAttr' (skinVertical sk) 1 maxHeight) cellImgsBottomPadded + True -> intersperse (charFill bAttr' (skinVertical sk) 1 maxHeight) cellImgsBottomPadded - return $ horiz_cat withBorders + return $ horizCat withBorders 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 @@ -57,7 +57,7 @@ -- |The type of formatted text widget state. Stores the text itself -- and the formatter used to apply attributes to the text. data FormattedText = - FormattedText { text :: TextStream Attr + FormattedText { textContent :: TextStream Attr , formatter :: !Formatter , useFocusAttribute :: !Bool } @@ -90,7 +90,7 @@ wrap :: Formatter wrap = Formatter $ \sz ts -> do - let width = Phys $ fromEnum $ region_width sz + let width = Phys $ fromEnum $ fst sz return $ wrapStream width ts -- |Construct a text widget formatted with the specified formatters @@ -98,7 +98,7 @@ -- given here (and, depending on the formatter, order might matter). textWidget :: Formatter -> T.Text -> IO (Widget FormattedText) textWidget format s = do - let initSt = FormattedText { text = TS [] + let initSt = FormattedText { textContent = TS [] , formatter = format , useFocusAttribute = False } @@ -110,7 +110,7 @@ ft <- getState this f <- focused <~ this appearFocused <- useFocusAttribute <~~ this - renderText (text ft) (f && appearFocused) (formatter ft) size ctx + renderText (textContent ft) (f && appearFocused) (formatter ft) size ctx } setText wRef s return wRef @@ -135,17 +135,17 @@ -- |Set the text value of a 'FormattedText' widget. The specified -- string will be 'tokenize'd. setText :: Widget FormattedText -> T.Text -> IO () -setText wRef s = setTextWithAttrs wRef [(s, def_attr)] +setText wRef s = setTextWithAttrs wRef [(s, defAttr)] -- |Append the text value to the text contained in a 'FormattedText' widget. -- The specified string will be 'tokenize'd. appendText :: Widget FormattedText -> T.Text -> IO () -appendText wRef s = appendTextWithAttrs wRef [(s, def_attr)] +appendText wRef s = appendTextWithAttrs wRef [(s, defAttr)] -- |Prepend the text value to the text contained in a 'FormattedText' widget. -- The specified string will be 'tokenize'd. prependText :: Widget FormattedText -> T.Text -> IO () -prependText wRef s = prependTextWithAttrs wRef [(s, def_attr)] +prependText wRef s = prependTextWithAttrs wRef [(s, defAttr)] -- |Prepend text to the text value of a 'FormattedText' widget directly, in -- case you have done formatting elsewhere and already have text with @@ -155,7 +155,7 @@ prependTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO () prependTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs f where - f st new = let TS old = text st + f st new = let TS old = textContent st in new ++ old -- |Append text to the text value of a 'FormattedText' widget directly, in case @@ -166,7 +166,7 @@ appendTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO () appendTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs f where - f st new = let TS old = text st + f st new = let TS old = textContent st in old ++ new -- |Set the text value of a 'FormattedText' widget directly, in case @@ -186,7 +186,7 @@ ts = concat $ map streamEntities streams updateWidgetState wRef $ \st -> - st { text = TS $ f st ts } + st { textContent = TS $ f st ts } -- |Low-level text-rendering routine. renderText :: TextStream Attr @@ -211,13 +211,13 @@ lineImgs = map mkLineImg ls lineLength l = length $ tokenStr <$> l maxLineLength = maximum $ lineLength <$> ls - emptyLineLength = min (fromEnum $ region_width sz) maxLineLength + emptyLineLength = min (fromEnum $ fst sz) maxLineLength ls = map truncLine $ map (map entityToken) $ findLines newText - truncLine = truncateLine (Phys $ fromEnum $ region_width sz) + truncLine = truncateLine (Phys $ fromEnum $ fst sz) -- When building images for empty lines, it's critical that we - -- *don't* use the empty_image, because that will cause empty + -- *don't* use the emptyImage, 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 @@ -225,15 +225,15 @@ -- 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' ' ' emptyLineLength 1 - else horiz_cat $ map mkTokenImg line - nullImg = string def_attr "" + then charFill attr' ' ' emptyLineLength 1 + else horizCat $ map mkTokenImg line + nullImg = string defAttr "" mkTokenImg :: Token Attr -> Image mkTokenImg tok = string (finalAttr tok) (T.unpack $ tokenStr tok) - return $ if region_height sz == 0 + return $ if snd sz == 0 then nullImg else if null ls || all null ls then nullImg - else vert_cat $ take (fromEnum $ region_height sz) lineImgs + else vertCat $ take (fromEnum $ snd sz) lineImgs 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 @@ -18,17 +18,15 @@ , chWidth , strWidth , textWidth + , regionWidth + , regionHeight , Phys(..) ) where import Control.Applicative -import Data.Word import qualified Data.Text as T import Graphics.Vty -import Graphics.Vty.Image - ( safe_wcwidth - ) -- A newtype to wrap physical screen coordinates, as opposed to -- character-logical coordinates. Used when transforming cursor @@ -38,7 +36,7 @@ deriving (Num, Eq, Show, Ord, Integral, Enum, Real) chWidth :: Char -> Phys -chWidth = Phys . fromEnum . safe_wcwidth +chWidth = Phys . fromEnum . safeWcwidth textWidth :: T.Text -> Phys textWidth = strWidth . T.unpack @@ -61,21 +59,21 @@ -- |Infix attribute constructor. Use: foregroundColor `on` -- backgroundColor. on :: Color -> Color -> Attr -on a b = def_attr `with_back_color` b `with_fore_color` a +on a b = defAttr `withBackColor` b `withForeColor` a -- |Foreground-only attribute constructor. Background color and style -- are defaulted. fgColor :: Color -> Attr -fgColor = (def_attr `with_fore_color`) +fgColor = (defAttr `withForeColor`) -- |Background-only attribute constructor. Foreground color and style -- are defaulted. bgColor :: Color -> Attr -bgColor = (def_attr `with_back_color`) +bgColor = (defAttr `withBackColor`) -- |Style-only attribute constructor. Colors are defaulted. style :: Style -> Attr -style = (def_attr `with_style`) +style = (defAttr `withStyle`) -- Left-most attribute's fields take precedence. -- |Merge two attributes. Leftmost attribute takes precedence where @@ -84,42 +82,42 @@ -- style mask will take precedence if any are set. mergeAttr :: Attr -> Attr -> Attr mergeAttr a b = - let b1 = case attr_style a of - SetTo v -> b { attr_style = SetTo v } + let b1 = case attrStyle a of + SetTo v -> b { attrStyle = SetTo v } _ -> b - b2 = case attr_fore_color a of - SetTo v -> b1 `with_fore_color` v + b2 = case attrForeColor a of + SetTo v -> b1 `withForeColor` v _ -> b1 - b3 = case attr_back_color a of - SetTo v -> b2 `with_back_color` v + b3 = case attrBackColor a of + SetTo v -> b2 `withBackColor` v _ -> b2 in b3 -- |List fold version of 'mergeAttr'. mergeAttrs :: [Attr] -> Attr -mergeAttrs attrs = foldr mergeAttr def_attr attrs +mergeAttrs attrs = foldr mergeAttr defAttr attrs -- |Modify the width component of a 'DisplayRegion'. -withWidth :: DisplayRegion -> Word -> DisplayRegion -withWidth (DisplayRegion _ h) w = DisplayRegion w h +withWidth :: DisplayRegion -> Int -> DisplayRegion +withWidth (_, h) w = (w, h) -- |Modify the height component of a 'DisplayRegion'. -withHeight :: DisplayRegion -> Word -> DisplayRegion -withHeight (DisplayRegion w _) h = DisplayRegion w h +withHeight :: DisplayRegion -> Int -> DisplayRegion +withHeight (w, _) h = (w, h) -- |Modify the width component of a 'DisplayRegion'. -plusWidth :: DisplayRegion -> Word -> DisplayRegion -plusWidth (DisplayRegion w' h) w = - if (fromEnum w' + fromEnum w < 0) +plusWidth :: DisplayRegion -> Int -> DisplayRegion +plusWidth (w', h) w = + if (w' + w < 0) then error $ "plusWidth: would overflow on " ++ (show w') ++ " + " ++ (show w) - else DisplayRegion (w + w') h + else ((w + w'), h) -- |Modify the height component of a 'DisplayRegion'. -plusHeight :: DisplayRegion -> Word -> DisplayRegion -plusHeight (DisplayRegion w h') h = - if (fromEnum h' + fromEnum h < 0) +plusHeight :: DisplayRegion -> Int -> DisplayRegion +plusHeight (w, h') h = + if (h' + h < 0) then error $ "plusHeight: would overflow on " ++ (show h') ++ " + " ++ (show h) - else DisplayRegion w (h + h') + else (w, (h + h')) remove :: Int -> [a] -> [a] remove pos as = (take pos as) ++ (drop (pos + 1) as) @@ -130,3 +128,9 @@ repl :: Int -> a -> [a] -> [a] repl !pos !a !as = inject pos a (remove pos as) + +regionWidth :: DisplayRegion -> Int +regionWidth = fst + +regionHeight :: DisplayRegion -> Int +regionHeight = snd diff --git a/test/src/Tests/FormattedText.hs b/test/src/Tests/FormattedText.hs --- a/test/src/Tests/FormattedText.hs +++ b/test/src/Tests/FormattedText.hs @@ -9,22 +9,23 @@ import Graphics.Vty import Graphics.Vty.Widgets.Text import Graphics.Vty.Widgets.Core +import Graphics.Vty.Widgets.Util import Tests.Util import Tests.Instances () sz :: DisplayRegion -sz = DisplayRegion 100 100 +sz = (100, 100) textHeight :: Property textHeight = monadicIO $ forAllM textString $ \str -> do w <- run $ plainText str img <- run $ render w sz defaultContext - if region_height sz == 0 then - return $ image_height img == 0 else - return $ image_height img == (toEnum $ numNewlines str + 1) + if regionHeight sz == 0 then + return $ imageHeight img == 0 else + return $ imageHeight img == (toEnum $ numNewlines str + 1) textImageSize :: Property textImageSize = diff --git a/test/src/Tests/Instances.hs b/test/src/Tests/Instances.hs --- a/test/src/Tests/Instances.hs +++ b/test/src/Tests/Instances.hs @@ -22,11 +22,6 @@ instance Arbitrary Attr where arbitrary = Attr <$> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary DisplayRegion where - arbitrary = DisplayRegion <$> coord <*> coord - where - coord = sized $ \n -> fromIntegral <$> choose (0, n) - instance Random Phys where random g = let (val, g') = random g diff --git a/test/src/Tests/Util.hs b/test/src/Tests/Util.hs --- a/test/src/Tests/Util.hs +++ b/test/src/Tests/Util.hs @@ -12,7 +12,7 @@ imageSize :: Image -> DisplayRegion -> Bool imageSize img sz = - image_width img <= region_width sz && image_height img <= region_height sz + imageWidth img <= regionWidth sz && imageHeight img <= regionHeight sz count :: (a -> Bool) -> [a] -> Int count _ [] = 0 @@ -21,15 +21,20 @@ numNewlines :: T.Text -> Int numNewlines = count (== '\n') . T.unpack +sizeGen :: Gen DisplayRegion +sizeGen = (,) + <$> (arbitrary `suchThat` (>= 0)) + <*> (arbitrary `suchThat` (>= 0)) + sizeTest :: (Show a) => IO (Widget a) -> PropertyM IO Bool sizeTest mkWidget = - forAllM arbitrary $ \sz -> do + forAllM sizeGen $ \sz -> do w <- run mkWidget img <- run $ render w sz defaultContext - if region_height sz == 0 || region_width sz == 0 then - return $ image_height img == 0 && image_width img == 0 else - return $ image_width img <= region_width sz && - image_height img <= region_height sz + if regionHeight sz == 0 || regionWidth sz == 0 then + return $ imageHeight img == 0 && imageWidth img == 0 else + return $ imageWidth img <= regionWidth sz && + imageHeight img <= regionHeight sz lineLength :: [Token a] -> Phys lineLength = sum . (textWidth <$>) . (tokenStr <$>) 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.7.1 +Version: 1.8 Synopsis: An interactive terminal user interface library for Vty @@ -89,7 +89,7 @@ Library Build-Depends: base >= 4 && < 5, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, containers >= 0.2 && < 0.6, regex-base >= 0.93 && < 0.94, directory >= 1.0 && < 1.3, @@ -99,7 +99,8 @@ stm >= 2.1 && < 2.5, array >= 0.3.0.0 && < 0.6.0.0, text >= 0.11, - vector >= 0.9 + vector >= 0.9, + data-default >= 0.5.3 GHC-Options: -Wall @@ -139,11 +140,11 @@ QuickCheck >= 2.4 && < 2.8, random >= 1.0, text, - vty < 5, + vty >= 5.1.0, vty-ui CPP-Options: -DTESTING - GHC-Options: -Wall + GHC-Options: -Wall -threaded if flag(no-tests) Buildable: False @@ -162,12 +163,12 @@ Executable vty-ui-collection-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: CollectionDemo.hs Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, text, vty-ui if !flag(demos) @@ -175,12 +176,12 @@ Executable vty-ui-list-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: ListDemo.hs Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, text, vty-ui if !flag(demos) @@ -188,12 +189,12 @@ Executable vty-ui-progressbar-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: ProgressBarDemo.hs Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, text, vty-ui if !flag(demos) @@ -201,7 +202,7 @@ Executable vty-ui-complex-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: ComplexDemo.hs Build-Depends: base >= 4 && < 5, @@ -209,7 +210,7 @@ bytestring >= 0.9 && < 1.0, time >= 1.1 && < 1.5, old-locale >= 1.0 && < 1.1, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, text, vty-ui if !flag(demos) @@ -217,24 +218,24 @@ Executable vty-ui-dirbrowser-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: DirBrowserDemo.hs Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, vty-ui if !flag(demos) Buildable: False Executable vty-ui-phoneinput-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: PhoneInputDemo.hs Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, text, vty-ui if !flag(demos) @@ -242,12 +243,12 @@ Executable vty-ui-dialog-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: DialogDemo.hs Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, text, vty-ui if !flag(demos) @@ -255,12 +256,12 @@ Executable vty-ui-edit-demo Hs-Source-Dirs: demos - GHC-Options: -Wall + GHC-Options: -Wall -threaded Main-is: EditDemo.hs Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, - vty >= 4.7.0.18 && < 5, + vty >= 5.1.0, vty-ui if !flag(demos) Buildable: False