Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-brick for openSUSE:Factory checked in at 2023-01-18 13:09:41 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-brick (Old) and /work/SRC/openSUSE:Factory/.ghc-brick.new.32243 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-brick" Wed Jan 18 13:09:41 2023 rev:22 rq:1059054 version:1.5 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-brick/ghc-brick.changes 2022-10-13 15:45:05.647083326 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-brick.new.32243/ghc-brick.changes 2023-01-18 13:09:50.296476379 +0100 @@ -1,0 +2,9 @@ +Thu Nov 24 18:20:39 UTC 2022 - Peter Simons <[email protected]> + +- Update brick to version 1.5. + Upstream has edited the change log file since the last release in + a non-trivial way, i.e. they did more than just add a new entry + at the top. You can review the file at: + http://hackage.haskell.org/package/brick-1.5/src/CHANGELOG.md + +------------------------------------------------------------------- Old: ---- brick-1.3.tar.gz New: ---- brick-1.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-brick.spec ++++++ --- /var/tmp/diff_new_pack.vsiqHR/_old 2023-01-18 13:09:50.928480009 +0100 +++ /var/tmp/diff_new_pack.vsiqHR/_new 2023-01-18 13:09:50.932480032 +0100 @@ -19,7 +19,7 @@ %global pkg_name brick %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.3 +Version: 1.5 Release: 0 Summary: A declarative terminal user interface library License: BSD-3-Clause ++++++ brick-1.3.tar.gz -> brick-1.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/CHANGELOG.md new/brick-1.5/CHANGELOG.md --- old/brick-1.3/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -2,6 +2,39 @@ Brick changelog --------------- +1.5 +--- + +This release focuses on API improvements in `Brick.Widgets.Dialog`: + +* `Dialog` got an additional type argument, `n`, for resource names. +* The `dialog` constructor now takes `[(String, n, a)]` rather than + `[(String, a)]`; this allows the caller to associate a resource name + with each dialog button. +* Dialog buttons now report click events under their associated resource + names. +* Dialog buttons now `putCursor` when they are focused in order to work + better with screen readers. +* The `Dialog` module got `getDialogFocus` and `setDialogFocus` + functions to help with focus management, and as part of this change, + the `dialogSelectedIndex` function and its lens `dialogSelectedIndexL` + were removed. + +1.4 +--- + +API changes: +* `Brick.Widgets.Border` got `hBorderAttr` and `vBorderAttr` for use by + `hBorder` and `vBorder` respectively. The new attributes inherit from + `borderAttr`, so applications that just specify `borderAttr` will not + see any change in behavior for those specific border elements. + +Performance improvements: +* `Brick.Widgets.Core.txt` had its performance improved. (thanks Fraser + Tweedale) +* `Brick.Widgets.Core.hBox` and `vBox` had their performance improved. + (thanks Fraser Tweedale) + 1.3 --- @@ -47,7 +80,7 @@ you to update your programs. This section details the list of API changes in 1.0 that are likely to introduce breakage and how to deal with each one. You can also consult the demonstration -programs to see orking examples of the new API. For those +programs to see working examples of the new API. For those interested in a bit of discussion on the changes, see [this ticket](https://github.com/jtdaugherty/brick/issues/379). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/README.md new/brick-1.5/README.md --- old/brick-1.3/README.md 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/README.md 2001-09-09 03:46:40.000000000 +0200 @@ -86,12 +86,14 @@ | [`kpxhs`](https://github.com/akazukin5151/kpxhs) | An interactive [Keepass](https://github.com/keepassxreboot/keepassxc/) database viewer | | [`htyper`](https://github.com/Simon-Hostettler/htyper) | A typing speed test program | | [`ullekha`](https://github.com/ajithnn/ullekha) | An interactive terminal notes/todo app with file/redis persistence | +| [`mywork`](https://github.com/kquick/mywork) [[Hackage]](https://hackage.haskell.org/package/mywork) | A tool to keep track of the projects you are working on | These third-party packages also extend `brick`: | Project | Description | | ------- | ----------- | | [`brick-filetree`](https://github.com/ChrisPenner/brick-filetree) [[Hackage]](http://hackage.haskell.org/package/brick-filetree) | A widget for exploring a directory tree and selecting or flagging files and directories | +| [`brick-panes`](https://github.com/kquick/brick-panes) [[Hackage]](https://hackage.haskell.org/package/brick-panes) | A Brick overlay library providing composition and isolation of screen areas for TUI apps. | Release Announcements / News ---------------------------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/brick.cabal new/brick-1.5/brick.cabal --- old/brick-1.3/brick.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/brick.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,5 @@ name: brick -version: 1.3 +version: 1.5 synopsis: A declarative terminal user interface library description: Write terminal user interfaces (TUIs) painlessly with 'brick'! You diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/programs/BorderDemo.hs new/brick-1.5/programs/BorderDemo.hs --- old/brick-1.3/programs/BorderDemo.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/programs/BorderDemo.hs 2001-09-09 03:46:40.000000000 +0200 @@ -73,6 +73,8 @@ borderMappings :: [(A.AttrName, V.Attr)] borderMappings = [ (B.borderAttr, V.yellow `on` V.black) + , (B.vBorderAttr, fg V.cyan) + , (B.hBorderAttr, fg V.magenta) , (titleAttr, fg V.cyan) ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/programs/DialogDemo.hs new/brick-1.5/programs/DialogDemo.hs --- old/brick-1.3/programs/DialogDemo.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/programs/DialogDemo.hs 2001-09-09 03:46:40.000000000 +0200 @@ -25,12 +25,18 @@ data Choice = Red | Blue | Green deriving Show -drawUI :: D.Dialog Choice -> [Widget ()] +data Name = + RedButton + | BlueButton + | GreenButton + deriving (Show, Eq, Ord) + +drawUI :: D.Dialog Choice Name -> [Widget Name] drawUI d = [ui] where ui = D.renderDialog d $ C.hCenter $ padAll 1 $ str "This is the dialog body." -appEvent :: BrickEvent () e -> T.EventM () (D.Dialog Choice) () +appEvent :: BrickEvent Name e -> T.EventM Name (D.Dialog Choice Name) () appEvent (VtyEvent ev) = case ev of V.EvKey V.KEsc [] -> M.halt @@ -38,12 +44,12 @@ _ -> D.handleDialogEvent ev appEvent _ = return () -initialState :: D.Dialog Choice -initialState = D.dialog (Just "Title") (Just (0, choices)) 50 +initialState :: D.Dialog Choice Name +initialState = D.dialog (Just $ str "Title") (Just (RedButton, choices)) 50 where - choices = [ ("Red", Red) - , ("Blue", Blue) - , ("Green", Green) + choices = [ ("Red", RedButton, Red) + , ("Blue", BlueButton, Blue) + , ("Green", GreenButton, Green) ] theMap :: A.AttrMap @@ -53,7 +59,7 @@ , (D.buttonSelectedAttr, bg V.yellow) ] -theApp :: M.App (D.Dialog Choice) e () +theApp :: M.App (D.Dialog Choice Name) e Name theApp = M.App { M.appDraw = drawUI , M.appChooseCursor = M.showFirstCursor diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/src/Brick/Widgets/Border.hs new/brick-1.5/src/Brick/Widgets/Border.hs --- old/brick-1.3/src/Brick/Widgets/Border.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/src/Brick/Widgets/Border.hs 2001-09-09 03:46:40.000000000 +0200 @@ -20,12 +20,17 @@ -- * Attribute names , borderAttr + , hBorderAttr + , vBorderAttr -- * Utility , joinableBorder ) where +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif import Lens.Micro ((^.), (&), (.~), to) import Graphics.Vty (imageHeight, imageWidth) @@ -41,6 +46,14 @@ borderAttr :: AttrName borderAttr = attrName "border" +-- | The horizontal border attribute name. Inherits from 'borderAttr'. +hBorderAttr :: AttrName +hBorderAttr = borderAttr <> attrName "horizontal" + +-- | The vertical border attribute name. Inherits from 'borderAttr'. +vBorderAttr :: AttrName +vBorderAttr = borderAttr <> attrName "vertical" + -- | Draw the specified border element using the active border style -- using 'borderAttr'. -- @@ -95,7 +108,8 @@ $ vLimit (middleResult^.imageL.to imageHeight + 2) $ total --- | A horizontal border. Fills all horizontal space. +-- | A horizontal border. Fills all horizontal space. Draws using +-- 'hBorderAttr'. hBorder :: Widget n hBorder = withAttr borderAttr $ Widget Greedy Fixed $ do @@ -105,7 +119,8 @@ db <- dynBorderFromDirections (Edges False False True True) let dynBorders = BM.insertH mempty (Run w db) $ BM.emptyCoordinates (Edges 0 0 0 (w-1)) - setDynBorders dynBorders $ render $ vLimit 1 $ fill (bsHorizontal bs) + setDynBorders dynBorders $ render $ withAttr hBorderAttr + $ vLimit 1 $ fill (bsHorizontal bs) -- | A horizontal border with a label placed in the center of the -- border. Fills all horizontal space. @@ -117,7 +132,8 @@ res <- render $ vLimit 1 label render $ hBox [hBorder, Widget Fixed Fixed (return res), hBorder] --- | A vertical border. Fills all vertical space. +-- | A vertical border. Fills all vertical space. Draws using +-- 'vBorderAttr'. vBorder :: Widget n vBorder = withAttr borderAttr $ Widget Fixed Greedy $ do @@ -127,7 +143,8 @@ db <- dynBorderFromDirections (Edges True True False False) let dynBorders = BM.insertV mempty (Run h db) $ BM.emptyCoordinates (Edges 0 (h-1) 0 0) - setDynBorders dynBorders $ render $ hLimit 1 $ fill (bsVertical bs) + setDynBorders dynBorders $ render $ withAttr vBorderAttr + $ hLimit 1 $ fill (bsVertical bs) -- | Initialize a 'DynBorder'. It will be 'bsDraw'n and 'bsOffer'ing -- in the given directions to begin with, and accept join offers from diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/src/Brick/Widgets/Core.hs new/brick-1.5/src/Brick/Widgets/Core.hs --- old/brick-1.3/src/Brick/Widgets/Core.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/src/Brick/Widgets/Core.hs 2001-09-09 03:46:40.000000000 +0200 @@ -268,17 +268,6 @@ unrestricted :: Int unrestricted = 100000 --- | Take a substring capable of fitting into the number of specified --- columns. This function takes character column widths into --- consideration. -takeColumns :: Int -> String -> String -takeColumns _ "" = "" -takeColumns numCols (c:cs) = - let w = V.safeWcwidth c - in if w > numCols - then [] - else c : takeColumns (numCols - w) cs - -- | Make a widget from a string, but wrap the words in the input's -- lines at the available width using the default wrapping settings. The -- input string should not contain escape sequences or carriage returns. @@ -296,9 +285,6 @@ strWrapWith :: WrapSettings -> String -> Widget n strWrapWith settings t = txtWrapWith settings $ T.pack t -safeTextWidth :: T.Text -> Int -safeTextWidth = V.safeWcswidth . T.unpack - -- | Make a widget from text, but wrap the words in the input's lines at -- the available width using the default wrapping settings. The input -- text should not contain escape sequences or carriage returns. @@ -322,15 +308,15 @@ case force theLines of [] -> return emptyResult multiple -> - let maxLength = maximum $ safeTextWidth <$> multiple + let maxLength = maximum $ textWidth <$> multiple padding = V.charFill (c^.attrL) ' ' (c^.availWidthL - maxLength) (length lineImgs) lineImgs = lineImg <$> multiple lineImg lStr = V.text' (c^.attrL) - (lStr <> T.replicate (maxLength - safeTextWidth lStr) " ") + (lStr <> T.replicate (maxLength - textWidth lStr) " ") in return $ emptyResult & imageL .~ (V.horizCat [V.vertCat lineImgs, padding]) --- | Build a widget from a 'String'. Breaks newlines up and space-pads --- short lines out to the length of the longest line. +-- | Build a widget from a 'String'. Behaves the same as 'txt' when the +-- input contains multiple lines. -- -- The input string must not contain tab characters. If it does, -- interface corruption will result since the terminal will likely @@ -338,25 +324,10 @@ -- replace tabs with the appropriate number of spaces as desired. The -- input string should not contain escape sequences or carriage returns. str :: String -> Widget n -str s = - Widget Fixed Fixed $ do - c <- getContext - let theLines = fixEmpty <$> (dropUnused . lines) s - fixEmpty :: String -> String - fixEmpty [] = " " - fixEmpty l = l - dropUnused l = takeColumns (availWidth c) <$> take (availHeight c) l - case force theLines of - [] -> return emptyResult - [one] -> return $ emptyResult & imageL .~ (V.string (c^.attrL) one) - multiple -> - let maxLength = maximum $ V.safeWcswidth <$> multiple - lineImgs = lineImg <$> multiple - lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - V.safeWcswidth lStr) ' ') - in return $ emptyResult & imageL .~ (V.vertCat lineImgs) +str = txt . T.pack --- | Build a widget from a 'T.Text' value. Behaves the same as 'str' --- when the input contains multiple lines. +-- | Build a widget from a 'T.Text' value. Breaks newlines up and +-- space-pads short lines out to the length of the longest line. -- -- The input string must not contain tab characters. If it does, -- interface corruption will result since the terminal will likely @@ -364,7 +335,44 @@ -- replace tabs with the appropriate number of spaces as desired. The -- input text should not contain escape sequences or carriage returns. txt :: T.Text -> Widget n -txt = str . T.unpack +txt s = + -- Althoguh vty Image uses lazy Text internally, using lazy text at this + -- level may not be an improvement. Indeed it can be much worse, due + -- the overhead of lazy Text being significant compared to the typically + -- short string content used to compose UIs. + Widget Fixed Fixed $ do + c <- getContext + let theLines = fixEmpty <$> (dropUnused . T.lines) s + fixEmpty l = if T.null l then T.singleton ' ' else l + dropUnused l = takeColumnsT (availWidth c) <$> take (availHeight c) l + pure $ case theLines of + [] -> emptyResult + [one] -> emptyResult & imageL .~ (V.text' (c^.attrL) one) + multiple -> + let maxLength = maximum $ V.safeWctwidth <$> multiple + lineImgs = lineImg <$> multiple + lineImg lStr = V.text' (c^.attrL) + (lStr <> T.replicate (maxLength - V.safeWctwidth lStr) (T.singleton ' ')) + in emptyResult & imageL .~ (V.vertCat lineImgs) + +-- | Take up to the given width, having regard to character width. +takeColumnsT :: Int -> T.Text -> T.Text +takeColumnsT w s = T.take (fst $ T.foldl' f (0,0) s) s + where + -- The accumulator value is (index in Text value, width of Text so far) + f (i,z) c + -- Width was previously exceeded; continue with same values. + | z < 0 = (i, z) + -- Width exceeded. Signal this with z = -1. Index will no longer be + -- incremented. + -- + -- Why not short circuit (e.g. using foldlM construction)? + -- Because in the typical case, the Either allocation costs exceed + -- any benefits. The pathological case, string length >> width, is + -- probably rare. + | z + V.safeWcwidth c > w = (i, -1) + -- Width not yet exceeded. Increment index and add character width. + | otherwise = (i + 1, z + V.safeWcwidth c) -- | Hyperlink the given widget to the specified URL. Not all terminal -- emulators support this. In those that don't, this should have no @@ -508,7 +516,6 @@ , imagePrimary :: V.Image -> Int , imageSecondary :: V.Image -> Int , limitPrimary :: Int -> Widget n -> Widget n - , limitSecondary :: Int -> Widget n -> Widget n , primaryWidgetSize :: Widget n -> Size , concatenatePrimary :: [V.Image] -> V.Image , concatenateSecondary :: [V.Image] -> V.Image @@ -534,7 +541,6 @@ , imagePrimary = V.imageHeight , imageSecondary = V.imageWidth , limitPrimary = vLimit - , limitSecondary = hLimit , primaryWidgetSize = vSize , concatenatePrimary = V.vertCat , concatenateSecondary = V.horizCat @@ -562,7 +568,6 @@ , imagePrimary = V.imageWidth , imageSecondary = V.imageHeight , limitPrimary = hLimit - , limitSecondary = vLimit , primaryWidgetSize = hSize , concatenatePrimary = V.horizCat , concatenateSecondary = V.vertCat @@ -639,18 +644,13 @@ (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed) pairsIndexed - let availPrimary = c^.(contextPrimary br) - availSecondary = c^.(contextSecondary br) - renderHi prim = do remainingPrimary <- get - result <- lift $ render $ limitPrimary br remainingPrimary - $ limitSecondary br availSecondary - $ cropToContext prim + result <- lift $ render $ limitPrimary br remainingPrimary prim result <$ (put $! remainingPrimary - (result^.imageL.(to $ imagePrimary br))) (renderedHis, remainingPrimary) <- - runStateT (traverse (traverse renderHi) his) availPrimary + runStateT (traverse (traverse renderHi) his) (c ^. contextPrimary br) renderedLows <- case lows of [] -> return [] @@ -660,10 +660,7 @@ primaries = replicate rest (primaryPerLow + 1) <> replicate (length ls - rest) primaryPerLow - let renderLow ((i, prim), pri) = - (i,) <$> (render $ limitPrimary br pri - $ limitSecondary br availSecondary - $ cropToContext prim) + let renderLow ((i, prim), pri) = (i,) <$> render (limitPrimary br pri prim) if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return [] @@ -886,7 +883,7 @@ -- , withAttr "highlight" (str b) -- ] -- --- render1 = renderA ("Brick", "fun") +-- render1 = renderA (\"Brick\", "fun") -- render2 = withAttr "warning" render1 -- @ -- @@ -930,7 +927,7 @@ -- , str " is " -- , withAttr "highlight" (str b) ] -- --- render1 = renderA ("Brick", "fun") +-- render1 = renderA (\"Brick\", "fun") -- render2 = withDefAttr "warning" render1 -- @ -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/brick-1.3/src/Brick/Widgets/Dialog.hs new/brick-1.5/src/Brick/Widgets/Dialog.hs --- old/brick-1.3/src/Brick/Widgets/Dialog.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/brick-1.5/src/Brick/Widgets/Dialog.hs 2001-09-09 03:46:40.000000000 +0200 @@ -5,21 +5,25 @@ -- dialog title, if any, as well as its body and buttons. -- -- Note that this dialog is really for simple use cases where you want --- to get the user's answer to a question, such as "Would you like --- to save changes before quitting?" If you require something more --- sophisticated, you'll need to build it yourself. You might also --- consider seeing the 'Brick.Forms' module for help with input --- management, and see the implementation of this module to see how to --- reproduce a dialog-style UI. +-- to get the user's answer to a question, such as "Would you like to +-- save changes before quitting?" As is typical in such cases, we assume +-- that this dialog box is used modally, meaning that while it is open +-- it is has exclusive input focus until it is closed. +-- +-- If you require something more sophisticated, you'll need to build it +-- yourself. You might also consider seeing the 'Brick.Forms' module for +-- help with input management and see the implementation of this module +-- to see how to reproduce a dialog-style UI. module Brick.Widgets.Dialog ( Dialog , dialogTitle , dialogButtons - , dialogSelectedIndex , dialogWidth -- * Construction and rendering , dialog , renderDialog + , getDialogFocus + , setDialogFocus -- * Handling events , handleDialogEvent -- * Getting a dialog's current value @@ -30,20 +34,20 @@ , buttonSelectedAttr -- * Lenses , dialogButtonsL - , dialogSelectedIndexL , dialogWidthL , dialogTitleL ) where import Lens.Micro +import Lens.Micro.Mtl ((%=)) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif -import Data.List (intersperse) +import Data.List (intersperse, find) import Graphics.Vty.Input (Event(..), Key(..)) -import Brick.Util (clamp) +import Brick.Focus import Brick.Types import Brick.Widgets.Core import Brick.Widgets.Center @@ -59,43 +63,55 @@ -- -- * Tab or Right Arrow: select the next button -- * Shift-tab or Left Arrow: select the previous button -data Dialog a = - Dialog { dialogTitle :: Maybe String +data Dialog a n = + Dialog { dialogTitle :: Maybe (Widget n) -- ^ The dialog title - , dialogButtons :: [(String, a)] - -- ^ The dialog button labels and values - , dialogSelectedIndex :: Maybe Int - -- ^ The currently selected dialog button index (if any) + , dialogButtons :: [(String, n, a)] + -- ^ The dialog buttons' labels, resource names, and values , dialogWidth :: Int -- ^ The maximum width of the dialog + , dialogFocus :: FocusRing n + -- ^ The focus ring for the dialog's buttons } suffixLenses ''Dialog -handleDialogEvent :: Event -> EventM n (Dialog a) () +handleDialogEvent :: Event -> EventM n (Dialog a n) () handleDialogEvent ev = do - modify $ \d -> case ev of - EvKey (KChar '\t') [] -> nextButtonBy 1 True d - EvKey KBackTab [] -> nextButtonBy (-1) True d - EvKey KRight [] -> nextButtonBy 1 False d - EvKey KLeft [] -> nextButtonBy (-1) False d - _ -> d + case ev of + EvKey (KChar '\t') [] -> dialogFocusL %= focusNext + EvKey KRight [] -> dialogFocusL %= focusNext + EvKey KBackTab [] -> dialogFocusL %= focusPrev + EvKey KLeft [] -> dialogFocusL %= focusPrev + _ -> return () + +-- | Set the focused button of a dialog. +setDialogFocus :: (Eq n) => n -> Dialog a n -> Dialog a n +setDialogFocus n d = d { dialogFocus = focusSetCurrent n $ dialogFocus d } + +-- | Get the focused button of a dialog. +getDialogFocus :: Dialog a n -> Maybe n +getDialogFocus = focusGetCurrent . dialogFocus -- | Create a dialog. -dialog :: Maybe String +dialog :: (Eq n) + => Maybe (Widget n) -- ^ The dialog title - -> Maybe (Int, [(String, a)]) - -- ^ The currently-selected button index (starting at zero) and - -- the button labels and values to use + -> Maybe (n, [(String, n, a)]) + -- ^ The currently-selected button resource name and the button + -- labels, resource names, and values to use for each button, + -- respectively -> Int -- ^ The maximum width of the dialog - -> Dialog a + -> Dialog a n dialog title buttonData w = - let (buttons, idx) = case buttonData of - Nothing -> ([], Nothing) - Just (_, []) -> ([], Nothing) - Just (i, bs) -> (bs, Just $ clamp 0 (length bs - 1) i) - in Dialog title buttons idx w + let (r, buttons) = case buttonData of + Nothing -> + (focusRing [], []) + Just (focName, entries) -> + let ns = (\(_, n, _) -> n) <$> entries + in (focusSetCurrent focName $ focusRing ns, entries) + in Dialog title buttons w r -- | The default attribute of the dialog dialogAttr :: AttrName @@ -113,17 +129,25 @@ -- dialog as a layer, which makes this suitable as a top-level layer in -- your rendering function to be rendered on top of the rest of your -- interface. -renderDialog :: Dialog a -> Widget n -> Widget n +renderDialog :: (Ord n) => Dialog a n -> Widget n -> Widget n renderDialog d body = let buttonPadding = str " " - mkButton (i, (s, _)) = let att = if Just i == d^.dialogSelectedIndexL - then buttonSelectedAttr - else buttonAttr - in withAttr att $ str $ " " <> s <> " " + foc = focusGetCurrent $ dialogFocus d + mkButton (s, n, _) = + let att = if Just n == foc + then buttonSelectedAttr + else buttonAttr + csr = if Just n == foc + then putCursor n (Location (1,0)) + else id + in csr $ + clickable n $ + withAttr att $ + str $ " " <> s <> " " buttons = hBox $ intersperse buttonPadding $ - mkButton <$> (zip [0..] (d^.dialogButtonsL)) + mkButton <$> (d^.dialogButtonsL) - doBorder = maybe border borderWithLabel (str <$> d^.dialogTitleL) + doBorder = maybe border borderWithLabel (d^.dialogTitleL) in centerLayer $ withDefAttr dialogAttr $ hLimit (d^.dialogWidthL) $ @@ -132,24 +156,12 @@ , hCenter buttons ] -nextButtonBy :: Int -> Bool -> Dialog a -> Dialog a -nextButtonBy amt wrapCycle d = - let numButtons = length $ d^.dialogButtonsL - in if numButtons == 0 then d - else case d^.dialogSelectedIndexL of - Nothing -> d & dialogSelectedIndexL .~ (Just 0) - Just i -> d & dialogSelectedIndexL .~ (Just newIndex) - where - addedIndex = i + amt - newIndex = if wrapCycle - then addedIndex `mod` numButtons - else max 0 $ min addedIndex $ numButtons - 1 - --- | Obtain the value associated with the dialog's currently-selected --- button, if any. This function is probably what you want when someone --- presses 'Enter' in a dialog. -dialogSelection :: Dialog a -> Maybe a -dialogSelection d = - case d^.dialogSelectedIndexL of - Nothing -> Nothing - Just i -> Just $ ((d^.dialogButtonsL) !! i)^._2 +-- | Obtain the resource name and value associated with the dialog's +-- currently-selected button, if any. The result of this function is +-- probably what you want when someone presses 'Enter' in a dialog. +dialogSelection :: (Eq n) => Dialog a n -> Maybe (n, a) +dialogSelection d = do + n' <- focusGetCurrent $ dialogFocus d + let matches (_, n, _) = n == n' + (_, n, a) <- find matches (d^.dialogButtonsL) + return (n, a)
