Add some button widgets and a rich-text widget

src-bin/example.hs

@@ -41,8 +41,8 @@ main = mainWidget $ do
               Region (w `div` 6) (h `div` 6) (w `div` 6) (h `div` 6)
             region2 = ffor size $ \(w,h) ->
               Region (2 * w `div` 6) (h `div` 6) (w `div` 6) (h `div` 6)
-        todo' <- pane region1 (pure True) $ button "Todo List"
-        editor <- pane region2 (pure True) $ button "Text Editor"
+        todo' <- pane region1 (pure True) $ textButtonStatic def "Todo List"
+        editor <- pane region2 (pure True) $ textButtonStatic def "Text Editor"
         return $ leftmost
           [ Left Example_TextEditor <$ editor
           , Left Example_Todo <$ todo'
@@ -63,7 +63,7 @@ taskList
   :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)
   => VtyWidget t m ()
 taskList = do
-  let btn = button $ pure "Add another task"
+  let btn = textButtonStatic def "Add another task"
   inp <- input
   rec let todos' = todos [Todo "First" True, Todo "Second" False, Todo "Third" False] $ leftmost
             [ () <$ e
@@ -122,11 +122,6 @@ checkbox v0 = do
   text $ current $ ffor v $ \v' -> if v' then "[x]" else "[ ]"
   return v
 
-button :: (Reflex t, Monad m) => Behavior t Text -> VtyWidget t m (Event t ())
-button t = do
-  boxStatic roundedBoxStyle $ text t
-  fmap (() <$) mouseUp
-
 data TodoOutput t = TodoOutput
   { _todoOutput_todo :: Dynamic t Todo
   , _todoOutput_delete :: Event t ()

src/Reflex/Vty/Widget.hs

@@ -44,8 +44,11 @@ module Reflex.Vty.Widget
   , splitVDrag
   , box
   , boxStatic
+  , RichTextConfig(..)
+  , richText
   , text
   , display
+  , BoxStyle(..)
   , hyphenBoxStyle
   , singleBoxStyle
   , roundedBoxStyle
@@ -535,20 +538,39 @@ boxStatic
   -> VtyWidget t m a
 boxStatic = box . pure
 
--- | Renders text, wrapped to the container width
-text
+-- | Configuration options for displaying "rich" text
+data RichTextConfig t = RichTextConfig
+  { _richTextConfig_attributes :: Behavior t V.Attr
+  }
+
+instance Reflex t => Default (RichTextConfig t) where
+  def = RichTextConfig $ pure V.defAttr
+
+-- | A widget that displays text with custom time-varying attributes
+richText
   :: (Reflex t, Monad m)
-  => Behavior t Text
+  => RichTextConfig t
+  -> Behavior t Text
   -> VtyWidget t m ()
-text msg = do
+richText cfg t = do
   dw <- displayWidth
-  let img = (\w s -> [wrapText w V.defAttr s]) <$> current dw <*> msg
+  let img = (\w a s -> [wrapText w a s])
+        <$> current dw
+        <*> _richTextConfig_attributes cfg
+        <*> t
   tellImages img
   where
     wrapText maxWidth attrs = V.vertCat
       . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
       . T.split (=='\n')
 
+-- | Renders text, wrapped to the container width
+text
+  :: (Reflex t, Monad m)
+  => Behavior t Text
+  -> VtyWidget t m ()
+text = richText def
+
 -- | Renders any behavior whose value can be converted to
 -- 'String' as text
 display
@@ -556,5 +578,3 @@ display
   => Behavior t a
   -> VtyWidget t m ()
 display a = text $ T.pack . show <$> a
-
-

src/Reflex/Vty/Widget/Input.hs

@@ -3,7 +3,61 @@ Module: Reflex.Vty.Widget.Input
 Description: User input widgets for reflex-vty
 -}
 module Reflex.Vty.Widget.Input
-  ( module Reflex.Vty.Widget.Input.Text
+  ( module Export
+  , module Reflex.Vty.Widget.Input
   ) where
 
-import Reflex.Vty.Widget.Input.Text
+
+import Reflex.Vty.Widget.Input.Text as Export
+
+import Data.Default
+import Data.Text (Text)
+import qualified Graphics.Vty as V
+import Reflex
+import Reflex.Vty.Widget
+
+-- | Configuration options for the 'button' widget
+data ButtonConfig t = ButtonConfig
+  { _buttonConfig_boxStyle :: Behavior t BoxStyle
+  }
+
+instance Reflex t => Default (ButtonConfig t) where
+  def = ButtonConfig (pure def)
+
+-- | A button widget that contains a sub-widget
+button
+  :: (Reflex t, Monad m)
+  => ButtonConfig t
+  -> VtyWidget t m ()
+  -> VtyWidget t m (Event t MouseUp)
+button cfg child = do
+  box (_buttonConfig_boxStyle cfg) child
+  mouseUp
+
+-- | A button widget that displays text that can change
+textButton
+  :: (Reflex t, Monad m)
+  => ButtonConfig t
+  -> Behavior t Text
+  -> VtyWidget t m (Event t MouseUp)
+textButton cfg = button cfg . text -- TODO Centering etc.
+
+-- | A button widget that displays a static bit of text
+textButtonStatic
+  :: (Reflex t, Monad m)
+  => ButtonConfig t
+  -> Text
+  -> VtyWidget t m (Event t MouseUp)
+textButtonStatic cfg = textButton cfg . pure
+
+-- | A clickable link widget
+link
+  :: (Reflex t, Monad m)
+  => Behavior t Text
+  -> VtyWidget t m (Event t MouseUp)
+link t = do
+  let cfg = RichTextConfig
+        { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline
+        }
+  richText cfg t
+  mouseUp