{-# LANGUAGE DataKinds #-}

-- | Widget paint helpers: labels, styles, rects, menu panels and display text.
module NanoUI.Frame.Chrome
  ( floatingAncestor
  , displayText
  , widgetVisualStyle
  , textInputValue
  , textInputFocused
  , fillStyledRect
  , strokeStyledRect
  , paintStyledRect
  , overlayWindowStyle
  , overlayModalStyle
  , overlayMenuStyle
  , paintMenuPanel
  , paintMenuAccent
  , paintScrollBarLayout
  , imageIdFromText
  , paintTabHeader
  , paintTableHeader
  ) where

import Control.Monad (when)
import Data.IORef (readIORef)
import qualified Data.IntMap.Strict as IM
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as TR
import NanoUI.Context
  ( Context (..)
  , WidgetStore (..)
  , getAnimationValue
  , getStore
  , intKey
  , nodeTheme
  )
import NanoUI.Draw (DrawArena, pushRect, pushRoundedRect, pushRoundedStroke)
import NanoUI.Font (menuAccentInset, menuAccentW)
import NanoUI.Frame.Scroll.Geometry (ScrollBarLayout (..))
import NanoUI.Id (hashWidgetId)
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (..)
  , getNodeType
  , getNodeValue
  , getOptions
  , getParent
  , getStyleIdx
  , getText
  , getWidgetId
  , isFloatingNode
  )
import NanoUI.Style
  ( Style (..)
  , Theme (..)
  , themeAccent
  , themeButton
  , themeFloatingWindow
  , themeInput
  , themeMuted
  , themePanel
  , themeWindow
  , themeOnAccent
  , themeShadow
  )
import NanoUI.Types (Color (..), Rect (..), colorA, colorRGBA, lerpColor)
import NanoUI.WidgetText
  ( buttonFlagsFromStyle
  , buttonVisualStyle
  , isMenuBarStyle
  , isMenuItemStyle
  , isTableHeaderStyle
  , selectDisplayText
  , stripeColor
  , tableHeaderDisplayText
  , textInputFieldText
  , textInputPasswordMode
  , treeDecodeStripe
  )

floatingAncestor :: Context -> NodeIdx -> IO (Maybe NodeType)
floatingAncestor :: Context -> Int -> IO (Maybe NodeType)
floatingAncestor Context
ctx Int
idx = Int -> IO (Maybe NodeType)
go Int
idx
  where
    go :: Int -> IO (Maybe NodeType)
go Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe NodeType -> IO (Maybe NodeType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NodeType
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          nt <- NodeArena -> Int -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) Int
i
          if isFloatingNode nt
            then pure (Just nt)
            else getParent (ctxNodeArena ctx) i >>= go

displayText :: Context -> NodeType -> NodeIdx -> IO Text
displayText :: Context -> NodeType -> Int -> IO Text
displayText Context
ctx NodeType
nt Int
idx = do
  txt <- NodeArena -> Int -> IO Text
getText (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  case nt of
    NodeType
NodeButton -> do
      si <- NodeArena -> Int -> IO Int
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      pure $! if isTableHeaderStyle si then tableHeaderDisplayText txt else txt
    NodeType
NodeTextInput -> Text -> Text -> Bool -> Text
textInputFieldText Text
txt (Text -> Bool -> Text) -> IO Text -> IO (Bool -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO Text
textInputValue Context
ctx Int
idx IO (Bool -> Text) -> IO Bool -> IO Text
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Context -> Int -> IO Bool
textInputFocused Context
ctx Int
idx
    NodeType
NodeTextArea -> Context -> Int -> IO Text
textInputValue Context
ctx Int
idx
    NodeType
NodeSelect -> Text -> Text -> Text
selectDisplayText Text
txt (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO Text
selectCurrentOption Context
ctx Int
idx
    NodeType
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
txt

selectCurrentOption :: Context -> NodeIdx -> IO Text
selectCurrentOption :: Context -> Int -> IO Text
selectCurrentOption Context
ctx Int
idx = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  opts <- getOptions (ctxNodeArena ctx) idx
  wid <- getWidgetId (ctxNodeArena ctx) idx
  let picked = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (WidgetId -> Int
intKey WidgetId
wid) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
  pure $ case drop picked opts of
    (Text
o : [Text]
_) -> Text
o
    [Text]
_ -> Text
""

-- | The text a field displays: its stored value, masked one character per
-- character for password inputs so caret and selection offsets still line up.
textInputValue :: Context -> NodeIdx -> IO Text
textInputValue :: Context -> Int -> IO Text
textInputValue Context
ctx Int
idx = do
  let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId NodeArena
na Int
idx
  nt <- getNodeType na idx
  si <- getStyleIdx na idx
  store <- getStore ctx
  let value = Text -> Int -> IntMap Text -> Text
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Text
"" (WidgetId -> Int
intKey WidgetId
wid) (WidgetStore -> IntMap Text
storeText WidgetStore
store)
  pure $
    if nt == NodeTextInput && textInputPasswordMode si
      then T.replicate (T.length value) "*"
      else value

textInputFocused :: Context -> NodeIdx -> IO Bool
textInputFocused :: Context -> Int -> IO Bool
textInputFocused Context
ctx Int
idx = do
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  focus <- readIORef (ctxFocusId ctx)
  pure (focus == wid)

-- | Transparent fills and no border.
clearStyle :: Style -> Style
clearStyle :: Style -> Style
clearStyle Style
s = Style
s {styleBg = clear, styleHoverBg = clear, styleActiveBg = clear, styleBorderWidth = 0}
  where
    clear :: Color
clear = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
0

closeButtonStyle :: Theme -> Bool -> Float -> Style
closeButtonStyle :: Theme -> Bool -> Float -> Style
closeButtonStyle Theme
theme Bool
isHot Float
animT =
  let btn :: Style
btn = Theme -> Style
themeButton Theme
theme
      muted :: Color
muted = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleFg Style
btn) (Style -> Color
styleBg (Theme -> Style
themePanel Theme
theme)) Float
0.42
      t :: Float
t = if Bool
isHot Bool -> Bool -> Bool
&& Bool -> Bool
not (Float
animT Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0) then Float
1 else Float
animT
   in (Style -> Style
clearStyle Style
btn) {styleFg = lerpColor muted (styleFg btn) t}

tabHeaderVisualStyle :: Theme -> Int -> Bool -> Style
tabHeaderVisualStyle :: Theme -> Int -> Bool -> Style
tabHeaderVisualStyle Theme
theme Int
styleIdx Bool
isActive =
  let panel :: Style
panel = Theme -> Style
themePanel Theme
theme
      btn :: Style
btn = Theme -> Style
themeButton Theme
theme
      muted :: Color
muted = Theme -> Color
themeMuted Theme
theme
      accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
      clear :: Color
clear = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
0
      hoverLift :: Color
hoverLift = Color -> Color -> Float -> Color
lerpColor (Theme -> Color
themeWindow Theme
theme) (Style -> Color
styleHoverBg Style
btn) Float
0.55
      (Float
cr, Color
activeBg, Color
activeFg, Float
activeBw, Color
inactFg) = case Int
styleIdx of
        Int
1 -> (Float
6, Color
accent, Theme -> Color
themeOnAccent Theme
theme, Float
0, Color
muted)
        Int
2 -> (Float
8, Style -> Color
styleBg Style
panel, Style -> Color
styleFg Style
panel, Float
1, Color
muted)
        Int
_ -> (Float
6, Style -> Color
styleBg Style
panel, Style -> Color
styleFg Style
panel, Float
1, Color -> Color -> Float -> Color
lerpColor Color
muted (Style -> Color
styleFg Style
panel) Float
0.78)
   in if Bool
isActive
        then Style
panel
          { styleBg = activeBg
          , styleHoverBg = activeBg
          , styleFg = activeFg
          , styleBorder = activeBg
          , styleBorderWidth = activeBw
          , styleCornerRadius = cr
          }
        else Style
panel
          { styleBg = clear
          , styleHoverBg = hoverLift
          , styleFg = inactFg
          , styleBorder = clear
          , styleBorderWidth = 0
          , styleCornerRadius = cr
          }

-- | Flat menu row / menu-bar entry. Transparent at rest, a hover highlight
-- (matching the text-field context menu), and an accent-tinted fill while it
-- owns an open drop-down (@val > 0.5@, menu-bar titles only).
menuItemVisualStyle :: Theme -> Float -> Style
menuItemVisualStyle :: Theme -> Float -> Style
menuItemVisualStyle Theme
theme Float
val =
  let menu :: Style
menu = Theme -> Style
overlayMenuStyle Theme
theme
      accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
      clear :: Color
clear = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
0
      openBg :: Color
openBg = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleBg Style
menu) Color
accent Float
0.3
      isOpen :: Bool
isOpen = Float
val Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5
   in Style
menu
        { styleBg = if isOpen then openBg else clear
        , styleHoverBg = if isOpen then openBg else styleHoverBg menu
        , styleActiveBg = lerpColor (styleBg menu) accent 0.4
        , styleBorder = clear
        , styleBorderWidth = 0
        -- The text-field context menu fills hovered rows with a square
        -- pushRect; keep the generic menu identical.
        , styleCornerRadius = 0
        }

tableHeaderVisualStyle :: Theme -> Bool -> Style
tableHeaderVisualStyle :: Theme -> Bool -> Style
tableHeaderVisualStyle Theme
theme Bool
isSorted =
  let btn :: Style
btn = Theme -> Style
themeButton Theme
theme
      accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
      headerBg :: Color
headerBg = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleBg (Theme -> Style
themePanel Theme
theme)) (Style -> Color
styleBg Style
btn) Float
0.55
   in Style
btn
        { styleBg = headerBg
        , styleHoverBg = lerpColor headerBg accent 0.18
        , styleActiveBg = lerpColor headerBg accent 0.28
        , styleFg = if isSorted then styleFg btn else themeMuted theme
        , styleBorderWidth = 0
        , styleCornerRadius = 0
        }

paintTabHeader :: DrawArena -> Theme -> Int -> Bool -> Style -> Float -> Float -> Float -> Float -> IO ()
paintTabHeader :: DrawArena
-> Theme
-> Int
-> Bool
-> Style
-> Float
-> Float
-> Float
-> Float
-> IO ()
paintTabHeader DrawArena
da Theme
theme Int
styleIdx Bool
isActive Style
style Float
x Float
y Float
w Float
h = do
  let rect :: Rect
rect = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
      r :: Float
r = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Style -> Float
styleCornerRadius Style
style)
      bg :: Color
bg = Style -> Color
styleBg Style
style
  if Bool
isActive
    then case Int
styleIdx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 of
      Int
1 -> DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
rect Float
r Color
bg
      Int
2 -> do
        DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
rect Float
r Color
bg
        DrawArena -> Style -> Rect -> IO ()
strokeStyledRect DrawArena
da Style
style Rect
rect
      Int
_ -> do
        DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
rect Float
r Color
bg
        DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w (Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1)) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
r (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2))) Float
1 (Style -> Color
styleBorder (Theme -> Style
themePanel Theme
theme))
        DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2) Float
w Float
2) (Theme -> Color
themeAccent Theme
theme)
    else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Color
bg Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
rect Float
r Color
bg

paintTableHeader :: DrawArena -> Theme -> Bool -> Style -> Float -> Float -> Float -> Float -> IO ()
paintTableHeader :: DrawArena
-> Theme
-> Bool
-> Style
-> Float
-> Float
-> Float
-> Float
-> IO ()
paintTableHeader DrawArena
da Theme
theme Bool
isSorted Style
style Float
x Float
y Float
w Float
h = do
  DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h) (Style -> Color
styleBg Style
style)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSorted (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2) Float
w Float
2) (Theme -> Color
themeAccent Theme
theme)

widgetVisualStyle :: Context -> NodeType -> NodeIdx -> IO Style
widgetVisualStyle :: Context -> NodeType -> Int -> IO Style
widgetVisualStyle Context
ctx NodeType
nt Int
idx = do
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  val <- getNodeValue (ctxNodeArena ctx) idx
  hot <- readIORef (ctxHotId ctx)
  active <- readIORef (ctxActiveId ctx)
  focus <- readIORef (ctxFocusId ctx)
  animT <- getAnimationValue ctx wid
  -- Only these node types consult the floating ancestor; skip the parent
  -- walk for the common panel/text/button path.
  let modalAware = NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeCheckbox Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeRadio Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTree Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeSlider
  mFloat <- if modalAware then floatingAncestor ctx idx else pure Nothing
  styleIdx <-
    if nt == NodeButton || nt == NodeTree
      then getStyleIdx (ctxNodeArena ctx) idx
      else pure 0
  let (isClose, isTab, isTable) =
        if nt == NodeButton
          then buttonFlagsFromStyle styleIdx
          else (False, False, False)
      isMenu = NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeButton Bool -> Bool -> Bool
&& (Int -> Bool
isMenuItemStyle Int
styleIdx Bool -> Bool -> Bool
|| Int -> Bool
isMenuBarStyle Int
styleIdx)
  theme <- nodeTheme ctx idx
  let isFocus = WidgetId
focus WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
      isHot = WidgetId
wid WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
hot
      focusBorder Style
s = if Bool
isFocus then Style
s {styleBorder = themeAccent theme} else Style
s
      base =
        case NodeType
nt of
          NodeType
NodeTextInput -> Style -> Style
focusBorder (Theme -> Style
themeInput Theme
theme)
          NodeType
NodeTextArea -> Style -> Style
focusBorder (Theme -> Style
themeInput Theme
theme)
          NodeType
NodeSelect -> Style -> Style
focusBorder (Theme -> Style
themeButton Theme
theme)
          NodeType
NodeColorPicker -> Style -> Style
focusBorder (Theme -> Style
themeInput Theme
theme)
          NodeType
NodeSlider -> Style -> Style
clearStyle (Theme -> Style
themeInput Theme
theme)
          NodeType
NodeCheckbox -> Style -> Style
clearStyle (Theme -> Style
themeButton Theme
theme)
          NodeType
NodeRadio -> Style -> Style
clearStyle (Theme -> Style
themeButton Theme
theme)
          NodeType
NodeTree ->
            let btn :: Style
btn = Theme -> Style
themeButton Theme
theme
                accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
                unselectedBg :: Color
unselectedBg =
                  case Theme -> Int -> Maybe Color
stripeColor Theme
theme (Int -> Int
treeDecodeStripe Int
styleIdx) of
                    Just Color
c -> Color
c
                    Maybe Color
Nothing -> Style -> Color
styleBg (Theme -> Style
themePanel Theme
theme)
             in if Float
val Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5
                  then
                    Style
btn
                      { styleBg = lerpColor unselectedBg accent 0.25
                      , styleHoverBg = lerpColor unselectedBg accent 0.35
                      , styleActiveBg = lerpColor unselectedBg accent 0.45
                      , styleBorderWidth = 0
                      , styleCornerRadius = 0
                      }
                  else
                    Style
btn
                      { styleBg = unselectedBg
                      , styleHoverBg = lerpColor unselectedBg accent 0.12
                      , styleActiveBg = lerpColor unselectedBg accent 0.22
                      , styleBorderWidth = 0
                      , styleCornerRadius = 0
                      }
          NodeType
NodeButton
            | Bool
isMenu -> Theme -> Float -> Style
menuItemVisualStyle Theme
theme Float
val
            | Bool
isClose -> Theme -> Bool -> Float -> Style
closeButtonStyle Theme
theme Bool
isHot Float
animT
            | Bool
isTab -> Theme -> Int -> Bool -> Style
tabHeaderVisualStyle Theme
theme (Int -> Int
buttonVisualStyle Int
styleIdx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4) (Float
val Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5)
            | Bool
isTable -> Theme -> Bool -> Style
tableHeaderVisualStyle Theme
theme (Float
val Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5)
            | Float
val Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5 ->
                (Theme -> Style
themeButton Theme
theme)
                  { styleBg = themeAccent theme
                  , styleHoverBg = themeAccent theme
                  , styleFg = themeOnAccent theme
                  , styleBorder = themeAccent theme
                  }
          NodeType
_ -> Theme -> Style
themeButton Theme
theme
      widgetBase =
        case Maybe NodeType
mFloat of
          Just NodeType
NodeModal | Bool
modalAware -> Theme -> Style
overlayModalStyle Theme
theme
          Maybe NodeType
_ -> Style
base
      bg
        | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTextInput, Bool
isFocus = Style -> Color
styleActiveBg Style
widgetBase
        | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTextArea, Bool
isFocus = Style -> Color
styleActiveBg Style
widgetBase
        | WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId -> Word64
hashWidgetId WidgetId
active = Style -> Color
styleActiveBg Style
widgetBase
        | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeCheckbox Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeRadio Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeSlider Bool -> Bool -> Bool
|| Bool
isClose = Style -> Color
styleBg Style
widgetBase
        | Bool
isMenu = if Bool
isHot then Style -> Color
styleHoverBg Style
widgetBase else Style -> Color
styleBg Style
widgetBase
        | Bool
otherwise = Style -> Float -> Bool -> Color
hoverBackground Style
widgetBase Float
animT Bool
isHot
  -- Idle widgets (no hover/active tint change) reuse the base style record
  -- rather than allocating a fresh Style through a record update.
  pure $! if bg == styleBg widgetBase then widgetBase else widgetBase {styleBg = bg}

hoverBackground :: Style -> Float -> Bool -> Color
hoverBackground :: Style -> Float -> Bool -> Color
hoverBackground Style
base Float
val Bool
isHot
  | Style -> Color
styleBg Style
base Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Style -> Color
styleHoverBg Style
base = Style -> Color
styleBg Style
base
  | Bool
isHot = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleBg Style
base) (Style -> Color
styleHoverBg Style
base) (if Float
val Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
val else Float
1)
  | Bool
otherwise = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleBg Style
base) (Style -> Color
styleHoverBg Style
base) Float
val

{-# INLINE fillStyledRect #-}
fillStyledRect :: DrawArena -> Style -> Rect -> IO ()
fillStyledRect :: DrawArena -> Style -> Rect -> IO ()
fillStyledRect DrawArena
da Style
style Rect
rect =
  if Style -> Float
styleCornerRadius Style
style Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0
    then DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da Rect
rect (Style -> Color
styleBg Style
style)
    else DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
rect (Style -> Float
styleCornerRadius Style
style) (Style -> Color
styleBg Style
style)

{-# INLINE strokeStyledRect #-}
strokeStyledRect :: DrawArena -> Style -> Rect -> IO ()
strokeStyledRect :: DrawArena -> Style -> Rect -> IO ()
strokeStyledRect DrawArena
da Style
style rect :: Rect
rect@(Rect Float
_ Float
_ Float
w Float
h) =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Style -> Float
styleBorderWidth Style
style Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let rr :: Float
rr = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Style -> Float
styleCornerRadius Style
style) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)))
    DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
rect Float
rr (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (Style -> Float
styleBorderWidth Style
style)) (Style -> Color
styleBorder Style
style)

-- | A style's fill, then its border.
{-# INLINE paintStyledRect #-}
paintStyledRect :: DrawArena -> Style -> Rect -> IO ()
paintStyledRect :: DrawArena -> Style -> Rect -> IO ()
paintStyledRect DrawArena
da Style
style Rect
rect = do
  DrawArena -> Style -> Rect -> IO ()
fillStyledRect DrawArena
da Style
style Rect
rect
  DrawArena -> Style -> Rect -> IO ()
strokeStyledRect DrawArena
da Style
style Rect
rect

overlayMenuStyle :: Theme -> Style
overlayMenuStyle :: Theme -> Style
overlayMenuStyle Theme
theme =
  let panel :: Style
panel = Theme -> Style
themePanel Theme
theme
      hover :: Color
hover =
        if Style -> Color
styleHoverBg Style
panel Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Style -> Color
styleBg Style
panel
          then Style -> Color
styleHoverBg (Theme -> Style
themeButton Theme
theme)
          else Style -> Color
styleHoverBg Style
panel
   in Style
panel
        { styleCornerRadius = 2
        , styleBorderWidth = 1
        , styleHoverBg = hover
        , styleActiveBg = lerpColor (styleBg panel) (themeAccent theme) 0.22
        }

overlayWindowStyle :: Theme -> Style
overlayWindowStyle :: Theme -> Style
overlayWindowStyle Theme
theme = (Theme -> Style
themeFloatingWindow Theme
theme) {styleCornerRadius = 2, styleBorderWidth = 1}

overlayModalStyle :: Theme -> Style
overlayModalStyle :: Theme -> Style
overlayModalStyle Theme
theme = (Theme -> Style
overlayMenuStyle Theme
theme) {styleCornerRadius = 2, styleBorderWidth = 1}

-- | Panel behind menus, dropdowns and floating windows: the theme's offset
-- shadow, then the styled fill and border.
paintMenuPanel :: DrawArena -> Theme -> Style -> Rect -> IO ()
paintMenuPanel :: DrawArena -> Theme -> Style -> Rect -> IO ()
paintMenuPanel DrawArena
da Theme
theme Style
style rect :: Rect
rect@(Rect Float
x Float
y Float
w Float
h) = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Color -> Word8
colorA (Theme -> Color
themeShadow Theme
theme) Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
3) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
3) Float
w Float
h) (Style -> Float
styleCornerRadius Style
style) (Theme -> Color
themeShadow Theme
theme)
  DrawArena -> Style -> Rect -> IO ()
paintStyledRect DrawArena
da Style
style Rect
rect

-- | Accent marker at a menu row's left edge, inset from its top and bottom.
paintMenuAccent :: DrawArena -> Theme -> Rect -> IO ()
paintMenuAccent :: DrawArena -> Theme -> Rect -> IO ()
paintMenuAccent DrawArena
da Theme
theme (Rect Float
x Float
y Float
_ Float
h) =
  DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect
    DrawArena
da
    (Float -> Float -> Float -> Float -> Rect
Rect Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
menuAccentInset) Float
menuAccentW (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
menuAccentInset)))
    Float
1
    (Theme -> Color
themeAccent Theme
theme)

-- | Scrollbar track and thumb, each rounded to at most 4px.
paintScrollBarLayout :: DrawArena -> Color -> Color -> ScrollBarLayout -> IO ()
paintScrollBarLayout :: DrawArena -> Color -> Color -> ScrollBarLayout -> IO ()
paintScrollBarLayout DrawArena
da Color
trackCol Color
thumbCol ScrollBarLayout
layout = do
  Rect -> Color -> IO ()
pill (ScrollBarLayout -> Rect
sbTrack ScrollBarLayout
layout) Color
trackCol
  Rect -> Color -> IO ()
pill (ScrollBarLayout -> Rect
sbThumb ScrollBarLayout
layout) Color
thumbCol
  where
    pill :: Rect -> Color -> IO ()
pill r :: Rect
r@(Rect Float
_ Float
_ Float
rw Float
rh) = DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
r (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
4 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
rw Float
rh Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2))

imageIdFromText :: Text -> Int
imageIdFromText :: Text -> Int
imageIdFromText Text
txt =
  case Reader Int
forall a. Integral a => Reader a
TR.decimal Text
txt of
    Right (Int
n, Text
rest) | Text -> Bool
T.null Text
rest, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Int
n
    Either String (Int, Text)
_ -> Int
0