reflex-vty-1.0.0.0: src-bin/example.hs

import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Functor
import Data.Functor.Misc
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import qualified Graphics.Vty as V
import Reflex
import Reflex.Network

import Data.Text.Zipper (TextAlignment (..))
import qualified Data.Text.Zipper as TZ
import Example.CPU
import Reflex.Vty

type VtyExample t m =
  ( MonadFix m
  , MonadHold t m
  , Reflex t
  , HasInput t m
  , HasImageWriter t m
  , HasDisplayRegion t m
  , HasFocus t m
  , HasFocusReader t m
  , HasTheme t m
  , HasColorProfile t m
  , HasCursor t m
  , HasScreenMode t m
  )

type Manager t m =
  ( HasLayout t m
  , HasFocus t m
  )

data Example
  = Example_TextEditor
  | Example_Todo
  | Example_ScrollableTextDisplay
  | Example_ClickButtonsGetEmojis
  | Example_CPUStat
  | Example_Scrollbar
  | Example_Cursor
  | Example_Showcase
  deriving (Bounded, Enum, Eq, Ord, Read, Show)

withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())
withCtrlC f = do
  inp <- input
  f
  return $ fforMaybe inp $ \case
    V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
    _ -> Nothing

-- * Shared styling helpers

-- | The brand accent color (cyan), matching the bright end of 'brandGradient'.
accent :: Color
accent = rgbColor 0 200 230

-- | A pink → violet → cyan true-color gradient used for the brand banner.
brandGradient :: Gradient1D
brandGradient =
  gradient1D
    [ (0.0, RGB 255 64 160)
    , (0.5, RGB 150 90 255)
    , (1.0, RGB 0 200 230)
    ]

-- | Emit a single line of bold text whose characters are colored along a
-- horizontal 1D gradient. Shows off true-color 'Gradient1D' sampling.
gradientText
  :: (Reflex t, HasImageWriter t m)
  => Gradient1D -> Text -> m ()
gradientText grad txt = tellImages $ pure [img]
  where
    cs = T.unpack txt
    n = length cs
    img =
      V.horizCat
        [ V.char (V.withStyle (V.withForeColor V.defAttr (fromRGB (sampleGradient1D grad p))) V.bold) c
        | (i, c) <- zip [0 :: Int ..] cs
        , let p = fromIntegral i / fromIntegral (max 1 (n - 1))
        ]

-- | A line of text tinted with an accent foreground color (used for the
-- short instructional headers above each example).
accentText
  :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
  => Color -> Text -> m ()
accentText c t =
  localTheme (const (pure (defTheme {_theme_default = withForeground c def}))) $
    text (pure t)

-- | A titled box whose border and title are tinted with an accent color,
-- while its content stays in the default theme so body text remains
-- readable.
accentBox
  :: ( MonadFix m
     , MonadHold t m
     , HasDisplayRegion t m
     , HasImageWriter t m
     , HasInput t m
     , HasFocusReader t m
     , HasTheme t m
     )
  => Color -> BoxStyle -> Text -> m a -> m a
accentBox c style title child =
  localTheme (const (pure (defTheme {_theme_default = withForeground c def}))) $
    boxTitle (pure TextAlignment_Center) (pure style) (pure title) $
      localTheme (const (pure defTheme)) child

-- | A theme transformer that reverse-videos the default style while the
-- given dynamic is True. Used to highlight a focused widget (e.g. the
-- checkbox in a to-do row).
highlightFocus
  :: Reflex t
  => Dynamic t Bool -> Behavior t Theme -> Behavior t Theme
highlightFocus d thB =
  (\th foc -> if foc then th {_theme_default = withReverse (_theme_default th)} else th)
    <$> thB
    <*> current d

main :: IO ()
main = mainWidget def $ withCtrlC $ do
  enterAlternateScreen
  initManager_ $ do
    tabNavigation
    let gf = grout . fixed
        t = tile (fixed 3)
        buttons = do
          (_, ev) <-
            scrollable def $
              col $ do
                gf 3 $ col $ do
                  gf 1 $ gradientText brandGradient "reflex-vty · functional reactive terminal UIs"
                  gf 1 $ text "Select an example."
                  gf 1 $ text "Esc brings you back here · Ctrl+C quits."
                a <- t $ textButtonStatic def "Todo List"
                b <- t $ textButtonStatic def "Text Editor"
                c <- t $ textButtonStatic def "Scrollable text display"
                d <- t $ textButtonStatic def "Clickable buttons"
                e <- t $ textButtonStatic def "CPU Usage"
                f <- t $ textButtonStatic def "Scrollbar modes"
                g <- t $ textButtonStatic def "Cursor"
                h <- t $ textButtonStatic def "Showcase"
                pure
                  ( never
                  , leftmost
                      [ Left Example_Todo <$ a
                      , Left Example_TextEditor <$ b
                      , Left Example_ScrollableTextDisplay <$ c
                      , Left Example_ClickButtonsGetEmojis <$ d
                      , Left Example_CPUStat <$ e
                      , Left Example_Scrollbar <$ f
                      , Left Example_Cursor <$ g
                      , Left Example_Showcase <$ h
                      ]
                  )
          pure ev
    let escapable w = do
          void w
          i <- input
          return $ fforMaybe i $ \case
            V.EvKey V.KEsc [] -> Just $ Right ()
            _ -> Nothing
    rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
          Left Example_Todo -> escapable taskList
          Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes
          Left Example_ScrollableTextDisplay -> escapable scrolling
          Left Example_ClickButtonsGetEmojis -> escapable easyExample
          Left Example_CPUStat -> escapable cpuStats
          Left Example_Scrollbar -> escapable scrollbarDemo
          Left Example_Cursor -> escapable cursorDemo
          Left Example_Showcase -> escapable showcaseDemo
          Right () -> buttons
    return ()

scrollbarDemo :: (VtyExample t m, Manager t m, MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => m ()
scrollbarDemo = col $ do
  grout (fixed 1) $ accentText accent "Four scrollbar modes. Use arrow keys or mouse wheel to scroll each panel:"
  grout flex $ row $ do
    grout flex $ void $ sbPanel "Always" ScrollbarAlways
    grout flex $ void $ sbPanel "Thumb Only" ScrollbarThumbOnly
    grout flex $ void $ sbPanel "While Scrolling" ScrollbarWhileScrolling
    grout flex $ void $ sbPanel "Hidden" ScrollbarHidden
  where
    sampleText = T.unlines $ map (\n -> "Line " <> T.pack (show n)) [(1 :: Int) .. 50]
    sbPanel label vis =
      boxTitle (pure TextAlignment_Center) (pure singleBoxStyle) (pure label) $
        scrollableText (def {_scrollableConfig_scrollbarVisibility = vis}) (constDyn sampleText)

-- * Terminal cursor demo

cursorDemo :: (VtyExample t m, Manager t m, MonadHold t m, PostBuild t m) => m ()
cursorDemo = col $ do
  grout (fixed 1) $ accentText accent "Arrows: move | s: style | v: visibility | f: alt-screen | Esc: back"
  let styles = [CursorStyleBlock, CursorStyleUnderline, CursorStyleBar]
  upE <- key V.KUp
  downE <- key V.KDown
  leftE <- key V.KLeft
  rightE <- key V.KRight
  sE <- key (V.KChar 's')
  vE <- key (V.KChar 'v')
  fE <- key (V.KChar 'f')
  posDyn <- foldDyn move (0, 0) $ leftmost [upE, downE, leftE, rightE]
  idxDyn <- foldDyn (\_ n -> (n + 1) `mod` length styles) 0 sE
  visDyn <- foldDyn (\_ b -> not b) True vE
  altDyn <- foldDyn (\_ b -> not b) True fE
  tellScreenMode $ (\b -> if b then ScreenAlternate else ScreenNormal) <$> updated altDyn
  let styleDyn = (styles !!) <$> idxDyn
      cursorDyn =
        (\(x, y) s v -> CursorState (if v then CursorVisible else CursorHidden) s (x, y))
          <$> posDyn
          <*> styleDyn
          <*> visDyn
  setCursor cursorDyn
  grout flex $
    text $
      current $
        ( \(x, y) s v a ->
            "Position: "
              <> T.pack (show x)
              <> ","
              <> T.pack (show y)
              <> " | Style: "
              <> T.pack (show s)
              <> " | Visible: "
              <> (if v then "on" else "off")
              <> " | Alt-screen: "
              <> (if a then "on" else "off")
        )
          <$> posDyn
          <*> styleDyn
          <*> visDyn
          <*> altDyn
  where
    move (k, _) (x, y) = case k of
      V.KUp -> (x, max 0 (y - 1))
      V.KDown -> (x, y + 1)
      V.KLeft -> (max 0 (x - 1), y)
      V.KRight -> (x + 1, y)
      _ -> (x, y)

-- * Mouse button and emojis example
easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
easyExample = do
  row $ grout (fixed 39) $ col $ do
    (a1, b1, c1) <- grout (fixed 3) $ row $ do
      a <- tile flex $ btn "POTATO"
      b <- tile flex $ btn "TOMATO"
      c <- tile flex $ btn "EGGPLANT"
      return (a, b, c)
    (a2, b2, c2) <- grout (fixed 3) $ row $ do
      a <- tile flex $ btn "CHEESE"
      b <- tile flex $ btn "BEES"
      c <- tile flex $ btn "MY KNEES"
      return (a, b, c)
    (a3, b3, c3) <- grout (fixed 3) $ row $ do
      a <- tile flex $ btn "TIME"
      b <- tile flex $ btn "RHYME"
      c <- tile flex $ btn "A BIG CRIME"
      return (a, b, c)
    tile (fixed 7) $ accentBox accent roundedBoxStyle "CLICK BUTTONS TO DRAW*" $ do
      outputDyn <-
        foldDyn (<>) "" $
          mergeWith
            (<>)
            [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]
      text (current outputDyn)
    tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map."
  inp <- input
  return $ fforMaybe inp $ \case
    V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
    _ -> Nothing
  where
    btn label = do
      let cfg = def {_buttonConfig_focusStyle = pure doubleBoxStyle}
      buttonClick <- textButtonStatic cfg label
      keyPress <-
        keyCombos $
          Set.fromList
            [ (V.KEnter, [])
            , (V.KChar ' ', [])
            ]
      pure $ leftmost [() <$ buttonClick, () <$ keyPress]

-- * Task list example
taskList
  :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
  => m ()
taskList = col $ do
  grout (fixed 1) $ accentText accent "To-Do · Tab to move · Ctrl+T toggles · Enter adds a task"
  let todos0 =
        [ Todo "Find reflex-vty" True
        , Todo "Become functional reactive" False
        , Todo "Make vty apps" False
        ]
      btn = textButtonStatic def "Add another task"
  enter <- fmap (const ()) <$> key V.KEnter
  rec void $ grout flex $ todos todos0 $ enter <> click
      click <- tile (fixed 3) btn
  return ()

data Todo = Todo
  { _todo_label :: Text
  , _todo_done :: Bool
  }
  deriving (Eq, Ord, Read, Show)

data TodoOutput t = TodoOutput
  { _todoOutput_todo :: Dynamic t Todo
  , _todoOutput_delete :: Event t ()
  , _todoOutput_height :: Dynamic t Int
  , _todoOutput_focusId :: FocusId
  , _todoOutput_focused :: Dynamic t Bool
  -- ^ Whether any element of this row (checkbox or text field) is focused.
  --   Used to insert a newly added task directly beneath the active row.
  }

todo
  :: (VtyExample t m, Manager t m, MonadHold t m)
  => Todo
  -> m (TodoOutput t)
todo t0 = row $ do
  let toggleKeys = Set.singleton (V.KChar 't', [V.MCtrl])
  anyChildFocused $ \focused -> do
    toggleE <- keyCombos toggleKeys
    filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do
      rec -- Which sub-element of this row has focus: the row is focused
          -- when either the checkbox or the text input is, so the
          -- checkbox is focused if the row is focused and the text isn't.
          textFocused <- isFocused fid
          let cbFocused = (\f tf -> f && not tf) <$> focused <*> textFocused
          -- A caret in a left gutter marks which to-do row is active.
          grout (fixed 2) $
            tellImages $
              ffor (current focused) $ \f ->
                [V.text' (V.withStyle (V.withForeColor V.defAttr accent) V.bold) (if f then "▸ " else "  ")]
          let cfg =
                def
                  { _checkboxConfig_setValue = setVal
                  }
          value <-
            tile (fixed 4) $
              localTheme (highlightFocus cbFocused) $
                checkbox cfg $
                  _todo_done t0
          let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE
          (fid, (ti, d)) <- tile' flex $ do
            i <- input
            v <-
              textInput $
                def
                  { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0
                  }
            let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
            return (v, deleteSelf)
      return $
        TodoOutput
          { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
          , _todoOutput_delete = d
          , _todoOutput_height = _textInput_lines ti
          , _todoOutput_focusId = fid
          , _todoOutput_focused = focused
          }
  where
    backspaceOnEmpty v = \case
      V.EvKey V.KBS _ | T.null v -> Just ()
      _ -> Nothing

todos
  :: forall t m
   . ( MonadHold t m
     , Manager t m
     , VtyExample t m
     , Adjustable t m
     , PostBuild t m
     )
  => [Todo]
  -> Event t ()
  -> m (Dynamic t (Map Rational (TodoOutput t)))
todos todos0 newTodo = do
  let todosMap0 = Map.fromList $ zip [0 ..] todos0
  rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
        to <- todo t
        let sel = select selectOnDelete $ Const2 k
        pb <- getPostBuild
        requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
        pure to
      let delete = flip Map.singleton Nothing <$> todoDelete
          todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
          -- The key of the row that currently holds focus, if any.
          focusedKey =
            fmap (fmap fst . Map.lookupMin . Map.filter id) $
              joinDynThroughMap $
                fmap _todoOutput_focused <$> listOut
          -- Insert the new task directly beneath the focused row by choosing a
          -- key halfway between it and the next row (so existing rows keep
          -- their keys and edit state). With no focus, or when the focused row
          -- is last, append at the end.
          insert = ffor (attach (current todosMap) (tag (current focusedKey) newTodo)) $ \(m, mfk) ->
            let newKey = case mfk of
                  Just fk -> case Map.lookupGT fk m of
                    Just (knext, _) -> (fk + knext) / 2
                    Nothing -> fk + 1
                  Nothing -> maybe 0 ((+ 1) . fst) (Map.lookupMax m)
            in Map.singleton newKey $ Just $ Todo "" False
          updates = leftmost [insert, delete]
          todoDelete =
            switch . current $
              leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut

          selectOnDelete =
            fanMap $
              (`Map.singleton` ())
                <$> attachWithMaybe
                  ( \m k ->
                      let (before, after) = Map.split k m
                      in fmap fst $ Map.lookupMax before <|> Map.lookupMin after
                  )
                  (current todosMap)
                  todoDelete
  return listOut

-- * Scrollable text example

scrolling
  :: ( VtyExample t m
     , MonadHold t m
     , Manager t m
     , PostBuild t m
     , MonadIO (Performable m)
     , TriggerEvent t m
     , PerformEvent t m
     )
  => m ()
scrolling = col $ do
  grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
  (fid, out) <- tile' (fixed 5) $ accentBox accent roundedBoxStyle " De Bello Gallico " $ scrollableText def $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
  pb <- getPostBuild
  requestFocus $ Refocus_Id fid <$ pb
  grout (fixed 1) $ text $ ffor (_scrollable_scrollPosition out) $ \p ->
    "Scrolled to " <> case p of
      ScrollPos_Top -> "top"
      ScrollPos_Bottom -> "bottom"
      ScrollPos_Line n -> "line " <> T.pack (show n)
  e <- performEventAsync $ ffor pb $ \_ cb -> liftIO $ void $ forkIO $ forever $ do
    threadDelay 1000000
    t <- getCurrentTime
    cb $ [T.pack $ show t]
  xs <- foldDyn (flip (<>)) [] e
  grout (fixed 3) blank
  tile (fixed 10) $ col $ do
    grout (fixed 1) $ text "This one scrolls automatically as the output grows:"
    Scrollable pos total h <-
      tile flex $
        scrollableText (ScrollableConfig never never ScrollPos_Bottom (pure $ Just ScrollToBottom_Maintain) ScrollbarAlways) $
          T.unlines <$> xs
    grout (fixed 5) $ accentBox accent singleBoxStyle " Scroll state " $ do
      grout (fixed 1) $ row $ do
        grout (fixed 8) (text "Height:")
        grout flex $ display h
      grout (fixed 1) $ row $ do
        grout (fixed 8) $ text "Scroll:"
        grout flex $ display pos
      grout (fixed 1) $ row $ do
        grout (fixed 8) $ text "Length:"
        grout flex $ display total

--  * Text editor example with resizable boxes

testBoxes
  :: (MonadHold t m, VtyExample t m)
  => m ()
testBoxes = do
  dw <- displayWidth
  dh <- displayHeight
  let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)
      region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)
  pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
  _ <-
    pane region2 (constDyn True) . boxStatic singleBoxStyle $
      let cfg =
            def
              { _textInputConfig_initialValue =
                  "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."
              }
          textBox =
            boxTitle (pure TextAlignment_Center) (pure roundedBoxStyle) "Text Edit" $
              multilineTextInput cfg
          dragBox = boxStatic roundedBoxStyle dragTest
      in splitVDrag (hRule doubleBoxStyle) textBox dragBox
  return ()
  where
    div' :: (Integral a, Applicative f) => f a -> f a -> f a
    div' = liftA2 div

debugInput :: (VtyExample t m, MonadHold t m) => m ()
debugInput = do
  lastEvent <- hold "No event yet" . fmap show =<< input
  text $ T.pack <$> lastEvent

dragTest :: (VtyExample t m, MonadHold t m) => m ()
dragTest = do
  lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
  text $ T.pack <$> lastEvent

-- * Showcase: one screen showing off all styling, theming, and color

-- profiling. Tab cycles the predefined themes; the whole screen is
-- rendered under the current theme.
showcaseDemo :: (VtyExample t m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), HasLayout t m, HasColorProfile t m) => m ()
showcaseDemo = do
  tab <- key (V.KChar '\t')
  nDyn <- foldDyn (\_ n -> n + 1) 0 tab
  prof <- colorProfile
  let themes =
        cycle
          [ ("default", defTheme)
          , ("dark", darkTheme)
          , ("charm", charmTheme)
          , ("dracula", draculaTheme)
          , ("nord", nordTheme)
          , ("zenburn", zenburnTheme)
          , ("gruvbox", gruvboxTheme)
          ]
      pick n = drop (n `mod` 7) themes
      curTheme n = case pick n of
        (_, th) : _ -> th
        [] -> defTheme
      curLabel n = case pick n of
        (label, _) : _ -> label
        [] -> ""
      themeBeh = curTheme <$> current nDyn
  focusGainedE <- gainedFocus
  focusLostE <- lostFocus
  focusedDyn <- holdDyn True $ leftmost [True <$ focusGainedE, False <$ focusLostE]
  mousePosDyn <- mousePosition
  let headerBeh =
        (\n p f (mx, my) -> T.pack (curLabel n <> " | " <> show p <> " | Focus: " <> (if f then "●" else "○") <> " | Mouse: " <> show mx <> "," <> show my <> " | Tab/Esc"))
          <$> current nDyn
          <*> prof
          <*> current focusedDyn
          <*> current mousePosDyn
  localTheme (const themeBeh) $ do
    fill (pure ' ')
    col $ do
      grout (fixed 1) $ text headerBeh
      grout flex $ void $ scrollable def $ do
        row $ do
          -- Left column: style samples
          grout flex $ col $ do
            grout (fixed 1) $ text "Borders:"
            grout (fixed 3) $ row $ do
              grout flex $ styledImage "single" (withBorder singleBorder def)
              grout flex $ styledImage "rounded" (withBorder roundedBorder def)
              grout flex $ styledImage "thick" (withBorder thickBorder def)
              grout flex $ styledImage "double" (withBorder doubleBorder def)
              grout flex $ styledImage "ascii" (withBorder asciiBorder def)
            grout (fixed 1) $ text "Padding/Margin:"
            grout (fixed 3) $ row $ do
              grout flex $ styledImage "pad 1" (withPadding 1 1 1 1 def)
              grout flex $ styledImage "pad 2" (withPadding 2 2 2 2 def)
              grout flex $ styledImage "margin 1" (withMargin 1 1 1 1 def)
            grout (fixed 1) $ text "Colors:"
            grout (fixed 3) $ row $ do
              grout flex $ styledImage "red fg" (withForeground red def)
              grout flex $ styledImage "blue bg" (withBackground blue def)
              grout flex $ styledImage "rgb" (withForeground (rgbColor 200 100 50) def)
            grout (fixed 1) $ text "Color ops:"
            grout (fixed 3) $ row $ do
              grout flex $ styledImage "darken" (withForeground (fromRGB (darken 0.4 (RGB 255 128 0))) def)
              grout flex $ styledImage "lighten" (withForeground (fromRGB (lighten 0.5 (RGB 100 0 200))) def)
              grout flex $ styledImage "mix" (withForeground (fromRGB (mix 0.5 (RGB 255 0 0) (RGB 0 0 255))) def)
              grout flex $ styledImage "complement" (withForeground (fromRGB (complementary (RGB 255 128 0))) def)
            grout (fixed 1) $ text "Gradient (1D):"
            grout (fixed 3) $ gradientSwatch
            grout (fixed 1) $ text "Canvas overlay:"
            grout (fixed 3) $ canvasOverlayDemo
            grout (fixed 1) $ text "Transforms:"
            grout (fixed 3) $ row $ do
              grout flex $ styledImage "bold" (withBold def)
              grout flex $ styledImage "italic" (withItalic def)
              grout flex $ styledImage "underline" (withUnderline UnderlineSingle def)
              grout flex $ styledImage "reverse" (withReverse def)
            grout (fixed 1) $ text "Alignment:"
            grout (fixed 3) $ row $ do
              grout flex $ styledImage "left" (withAlignH HAlignLeft . withWidth 20 $ def)
              grout flex $ styledImage "center" (withAlignH HAlignCenter . withWidth 20 $ def)
              grout flex $ styledImage "right" (withAlignH HAlignRight . withWidth 20 $ def)
            grout (fixed 1) $ text "Combined & Hyperlink:"
            grout (fixed 5) $ row $ do
              grout flex $
                styledImage
                  "combined"
                  ( withBorder roundedBorder
                      . withPadding 1 2 1 2
                      . withForeground brightGreen
                      . withBorderForeground brightMagenta
                      $ def
                  )
              grout flex $
                styledImage
                  "link"
                  (withHyperlink "https://reflex-frp.org" . withUnderline UnderlineSingle $ def)
          -- Right column: themed widgets + color profile swatches
          grout flex $ col $ do
            grout (fixed 1) $ text "Themed Widgets:"
            void $ grout (fixed 3) $ textButtonStatic def "A button"
            void $ grout (fixed 3) $ checkbox def False
            void $ grout (fixed 3) $ linkStatic "A link"
            void $ grout (fixed 3) $ textInput def
            grout (fixed 1) $ text "Color Profile Swatches:"
            grout (fixed 2) $ row $ do
              grout flex $ profileSwatch "TrueColor" ColorProfile_TrueColor
              grout flex $ profileSwatch "Ansi256" ColorProfile_Ansi256
              grout flex $ profileSwatch "Ansi16" ColorProfile_Ansi16
              grout flex $ profileSwatch "Ascii" ColorProfile_Ascii
              grout flex $ profileSwatch "NoTTY" ColorProfile_NoTTY
        pure (never, ())
  where
    orange = rgbColor 200 100 50
    styledImage label s = do
      th <- theme
      tellImages $ (\t -> [render (inherit (_theme_default t) s) label]) <$> th
    profileSwatch label prof = do
      bt <- themeAttr
      tellImages $ (\a -> [V.text' (applyProfile prof (V.withForeColor a orange)) (label <> " ")]) <$> bt
    gradientSwatch = do
      th <- theme
      dw <- displayWidth
      let grad = gradient1D [(0.0, RGB 255 0 0), (0.5, RGB 0 255 0), (1.0, RGB 0 0 255)]
          sampleAt w i = sampleGradient1D grad (fromIntegral i / fromIntegral (max 1 (w - 1)))
          bar t w = [V.horizCat $ map (\i -> render (inherit (_theme_default t) (withBackground (fromRGB (sampleAt w i)) def)) " ") [0 .. max 1 (w - 1)]]
      tellImages $ bar <$> th <*> current dw
    canvasOverlayDemo = do
      th <- theme
      let bgText = "background text shows through around the overlay"
          mkCanvas t =
            let bgBase = applyAttr (inherit (_theme_default t) def) V.defAttr
                bgRow = V.text' bgBase bgText
                bg = imageToCanvas $ V.vertCat [bgRow, bgRow, bgRow]
                overlayStyle =
                  withBorder roundedBorder
                    . withBackground (fromRGB (RGB 40 42 54))
                    . withForeground (fromRGB (RGB 255 184 108))
                    $ def
                overlayCanvas = imageToCanvas $ render overlayStyle " Overlay "
                result = placeCanvas 3 0 overlayCanvas bg
            in [canvasToImage result]
      tellImages $ mkCanvas <$> th