-- | Show lipstick blocks in brick and vty applications.
--
-- > ui :: Widget ()
-- > ui = blockWidget defaultRenderEnv (render (border roundedBorder <> padding 1 2) "Hello")
--
-- Widgets lay their block out in the width brick gives them, and take all
-- of it ('Greedy') when the block grows. Colours are resolved for the
-- 'RenderEnv' (light or dark background, profile) and handed to vty, which
-- downsamples them further if its output needs it. 'profileForColorMode'
-- gives the profile matching a vty output.
--
-- vty measures text with its own width tables, which can disagree with
-- lipstick's for some emoji; layouts made of such characters may be off by
-- a column.
--
-- vty has a single underline style and no underline colour: curly, double,
-- dotted and dashed underlines become plain ones, and underline colours are
-- dropped.
module Lipstick.Brick
  ( blockWidget
  , blockImage
  , profileForColorMode
  ) where

import Brick.Types (Size (..), Widget (..), availWidthL, getContext)
import Brick.Widgets.Core (raw)
import Lens.Micro ((^.))
import Data.Maybe (fromMaybe)
import Graphics.Vty qualified as V
import Lipstick (Attrs (..), Block, ColorProfile (..), RenderEnv (..), TermColor (..), Underline (..), blockGrows, escapeUri, layout, resolveColor)
import Lipstick.Grid (Span (..), gridLines, lineSpans)

-- | A widget showing a block, laid out in the width brick makes available
-- (whatever the environment's 'envWidth'). It is 'Greedy' horizontally
-- when the block grows (see 'Lipstick.fillWidth'), and 'Fixed' otherwise.
blockWidget :: RenderEnv -> Block -> Widget n
blockWidget :: forall n. RenderEnv -> Block -> Widget n
blockWidget RenderEnv
env Block
b = Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
policy Size
Fixed (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
  ctx <- RenderM n (Context n)
forall n. RenderM n (Context n)
getContext
  render (raw (blockImage env {envWidth = Just (ctx ^. availWidthL)} b))
  where
    policy :: Size
policy = if Block -> Bool
blockGrows Block
b then Size
Greedy else Size
Fixed

-- | A vty image of a block laid out in the environment's 'envWidth', as
-- wide and tall as the laid-out block (but see the note on widths above).
-- vty has no zero-width images, so a block 0 columns wide gives
-- 'V.emptyImage' whatever its height.
blockImage :: RenderEnv -> Block -> V.Image
blockImage :: RenderEnv -> Block -> Image
blockImage RenderEnv
env Block
b = [Image] -> Image
V.vertCat ((Line -> Image) -> [Line] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Image
line (Grid -> [Line]
gridLines (Maybe Int -> Block -> Grid
layout (RenderEnv -> Maybe Int
envWidth RenderEnv
env) Block
b)))
  where
    line :: Line -> Image
line Line
l = [Image] -> Image
V.horizCat [Attr -> Text -> Image
V.text' (RenderEnv -> Attrs -> Attr
attr RenderEnv
env (Span -> Attrs
spanAttrs Span
s)) (Span -> Text
spanText Span
s) | Span
s <- Line -> [Span]
lineSpans Line
l]

-- | The profile to resolve colours for, given a vty output's colour mode.
profileForColorMode :: V.ColorMode -> ColorProfile
profileForColorMode :: ColorMode -> ColorProfile
profileForColorMode = \case
  ColorMode
V.NoColor -> ColorProfile
Ascii
  ColorMode
V.ColorMode8 -> ColorProfile
ANSI16
  ColorMode
V.ColorMode16 -> ColorProfile
ANSI16
  V.ColorMode240 Word8
_ -> ColorProfile
ANSI256
  ColorMode
V.FullColor -> ColorProfile
TrueColor

attr :: RenderEnv -> Attrs -> V.Attr
attr :: RenderEnv -> Attrs -> Attr
attr RenderEnv
env Attrs
a
  | ColorProfile
profile ColorProfile -> ColorProfile -> Bool
forall a. Eq a => a -> a -> Bool
== ColorProfile
NoTTY = Attr
V.defAttr
  | Bool
otherwise =
      (Attr -> Color -> Attr) -> Maybe Color -> Attr -> Attr
withColor Attr -> Color -> Attr
V.withForeColor (Attrs -> Maybe Color
attrFg Attrs
a)
        (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> Color -> Attr) -> Maybe Color -> Attr -> Attr
withColor Attr -> Color -> Attr
V.withBackColor (Attrs -> Maybe Color
attrBg Attrs
a)
        (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Attr -> Attr
withLink (Attrs -> Maybe Text
attrLink Attrs
a)
        (Attr -> Attr) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ (Attr -> Word8 -> Attr) -> Attr -> [Word8] -> Attr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Attr -> Word8 -> Attr
V.withStyle Attr
V.defAttr [Word8]
styles
  where
    profile :: ColorProfile
profile = RenderEnv -> ColorProfile
envProfile RenderEnv
env
    withColor :: (Attr -> Color -> Attr) -> Maybe Color -> Attr -> Attr
withColor Attr -> Color -> Attr
f Maybe Color
c Attr
x = Attr -> (TermColor -> Attr) -> Maybe TermColor -> Attr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attr
x (Attr -> Color -> Attr
f Attr
x (Color -> Attr) -> (TermColor -> Color) -> TermColor -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermColor -> Color
vtyColor) (Maybe Color
c Maybe Color -> (Color -> Maybe TermColor) -> Maybe TermColor
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ColorProfile -> Bool -> Color -> Maybe TermColor
resolveColor ColorProfile
profile (RenderEnv -> Bool
envDarkBackground RenderEnv
env))
    withLink :: Maybe Text -> Attr -> Attr
withLink Maybe Text
url Attr
x = Attr -> (Text -> Attr) -> Maybe Text -> Attr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attr
x (Attr -> Text -> Attr
V.withURL Attr
x (Text -> Attr) -> (Text -> Text) -> Text -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeUri) Maybe Text
url
    on :: (Attrs -> Maybe Bool) -> Bool
on Attrs -> Maybe Bool
f = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Attrs -> Maybe Bool
f Attrs
a)
    styles :: [Word8]
styles =
      [Word8
V.bold | (Attrs -> Maybe Bool) -> Bool
on Attrs -> Maybe Bool
attrBold]
        [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
V.dim | (Attrs -> Maybe Bool) -> Bool
on Attrs -> Maybe Bool
attrFaint]
        [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
V.italic | (Attrs -> Maybe Bool) -> Bool
on Attrs -> Maybe Bool
attrItalic]
        [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
V.blink | (Attrs -> Maybe Bool) -> Bool
on Attrs -> Maybe Bool
attrBlink]
        [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
V.reverseVideo | (Attrs -> Maybe Bool) -> Bool
on Attrs -> Maybe Bool
attrReverse]
        [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
V.strikethrough | (Attrs -> Maybe Bool) -> Bool
on Attrs -> Maybe Bool
attrStrikethrough]
        [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
V.underline | Bool -> (Underline -> Bool) -> Maybe Underline -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Underline -> Underline -> Bool
forall a. Eq a => a -> a -> Bool
/= Underline
NoUnderline) (Attrs -> Maybe Underline
attrUnderline Attrs
a)]

vtyColor :: TermColor -> V.Color
vtyColor :: TermColor -> Color
vtyColor = \case
  TC16 Word8
n -> Word8 -> Color
V.ISOColor Word8
n
  TC256 Word8
n
    | Word8
n Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
16 -> Word8 -> Color
V.ISOColor Word8
n
    | Bool
otherwise -> Word8 -> Color
V.Color240 (Word8
n Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
16)
  TCRGB Word8
r Word8
g Word8
b -> Word8 -> Word8 -> Word8 -> Color
V.RGBColor Word8
r Word8
g Word8
b