-- Widget chrome painters for NanoUI, extracted from NanoUI.Frame.Paint so the
-- recursive node walker stays small. Every exported painter carries the paint
-- env built by Paint.buildPaintEnv; the walker's explicit dispatch hands each
-- widget node to one of these NOINLINE seams instead of inlining a monolithic
-- body into the loop.
{-# OPTIONS_GHC -fasm -fno-specialise-aggressively #-}

{-# LANGUAGE DataKinds #-}

module NanoUI.Frame.Paint.Widgets
  ( paintWidget
  , paintTextInputNode
  , paintTextAreaNode
  ) where

import Control.Monad (unless, when)
import Data.IORef (readIORef)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import NanoUI.Context (Context (..), getStore)
import NanoUI.Draw
  ( DrawArena (..)
  , pushCircle
  , pushFilledTriangle
  , pushLine
  , pushRoundedRect
  , pushRoundedRectRaw
  , pushRoundedStroke
  , pushStrokeAA
  , pushText
  , withClip
  )
import NanoUI.Font
  ( FontMetrics (..)
  , centeredTextY
  , checkboxBoxSize
  , sliderHandleDiameter
  , sliderTrackBounds
  , tableCellInset
  , treeChevronRect
  )
import NanoUI.Frame.Chrome
  ( fillStyledRect
  , paintMenuAccent
  , paintTabHeader
  , paintTableHeader
  , strokeStyledRect
  , paintStyledRect
  , textInputFocused
  , textInputValue
  , widgetVisualStyle
  )
import NanoUI.Frame.Node (resolveFontFor)
import NanoUI.Frame.Paint.Types (PaintEnv (..), popupPanelRect)
import NanoUI.Frame.Spans (forWidgetTextPlacements_, selectableTextGeometry, widgetTextSpans)
import NanoUI.Frame.TextArea (drawTextAreaContentWith)
import NanoUI.Frame.TextArea.Content (resolveTextAreaFont)
import NanoUI.Frame.TextInput
  ( FieldEdit
  , drawTextInputCaret
  , drawTextInputSelection
  , readFieldEdit
  , syncTextInputScroll
  , textInputFieldRect
  , textInputFieldTextClip
  )
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (..)
  , getNodeFontColor
  , getNodeFontSize
  , getNodeValue
  , getOptions
  , getStyleIdx
  , getText
  , getWidgetId
  )
import NanoUI.Style (Style, styleBg, styleBorder, styleFg, themeAccent, themeInput, themeOnAccent)
import NanoUI.Types (Color (..), Rect (..), clamp01, colorA, lerpColor, onGrid)
import NanoUI.WidgetText
  ( buttonCloseTrailing
  , buttonVisualStyle
  , comboTextClip
  , isCloseButtonStyle
  , isMenuBarStyle
  , isMenuItemStyle
  , isTabButtonStyle
  , isTableHeaderStyle
  , numericStepperRects
  , numericTextClip
  , searchFieldIconRects
  , searchFieldTextClip
  , selectChevronCenterX
  , selectChevronReserve
  , tableSortMarkOf
  , textInputNumericMode
  , textInputFieldText
  , textInputSearchMode
  , textInputSelectableMode
  , treeDecodeStyle
  )
import NanoUI.Widgets.ColorPicker (drawColorPickerPart)

-- | Single-line text input: selectable, bare, search, combo or captioned field
-- depending on the node's visual style.
{-# NOINLINE paintTextInputNode #-}
paintTextInputNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintTextInputNode :: PaintEnv -> Int -> Rect -> IO ()
paintTextInputNode PaintEnv
env Int
idx rect :: Rect
rect@(Rect Float
x Float
y Float
w Float
h) = do
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
      fm :: FontMetrics
fm = PaintEnv -> FontMetrics
peFontMetrics PaintEnv
env
  style <- Context -> NodeType -> Int -> IO Style
widgetVisualStyle Context
ctx NodeType
NodeTextInput Int
idx
  focus <- textInputFocused ctx idx
  si <- getStyleIdx (peNodeArena env) idx
  if textInputNumericMode si
    then paintNumericField ctx da fm style idx focus rect
    else
      if textInputSelectableMode si
        then paintSelectableText env style idx rect
        else
          if textInputSearchMode si
            then do
              opts <- getOptions (peNodeArena env) idx
              if null opts
                then paintSearchField ctx da fm style idx focus rect
                else paintComboField ctx da fm style idx focus rect
            else do
              let field = FontMetrics -> Float -> Float -> Float -> Float -> Rect
textInputFieldRect FontMetrics
fm Float
x Float
y Float
w Float
h
              paintStyledRect da style field
              spans <- widgetTextSpans ctx NodeTextInput idx x y w h
              case spans of
                (Rect Float
fx Float
fy Float
_ Float
_, Text
txt, Color
ffg, Color
_) : [(Rect, Text, Color, Color)]
_ -> do
                  mEdit <- Context
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO (Maybe FieldEdit)
readFieldEdit Context
ctx Int
idx Float
x Float
y Float
w Float
h (Float -> IO (Maybe FieldEdit)) -> IO Float -> IO (Maybe FieldEdit)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context -> Int -> Float -> Float -> Float -> Float -> IO Float
syncTextInputScroll Context
ctx Int
idx Float
x Float
y Float
w Float
h
                  paintClippedFieldText ctx da fm style idx mEdit (textInputFieldTextClip fm field) fx fy txt ffg
                [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Multi-line text area.
{-# NOINLINE paintTextAreaNode #-}
paintTextAreaNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintTextAreaNode :: PaintEnv -> Int -> Rect -> IO ()
paintTextAreaNode PaintEnv
env Int
idx (Rect Float
x Float
y Float
w Float
h) = do
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
  style <- Context -> NodeType -> Int -> IO Style
widgetVisualStyle Context
ctx NodeType
NodeTextArea Int
idx
  areaFm <- resolveTextAreaFont ctx idx
  paintStyledRect da style (Rect x y w h)
  drawTextAreaContentWith da ctx areaFm idx x y w h style

-- | Generic foreground / chrome widget (button, checkbox, radio, slider,
-- select, tree row, color swatch, table / tab header, ...). Splits into a
-- background pass and a label pass, both behind NOINLINE seams.
{-# NOINLINE paintWidget #-}
paintWidget :: PaintEnv -> NodeIdx -> NodeType -> Rect -> IO ()
paintWidget :: PaintEnv -> Int -> NodeType -> Rect -> IO ()
paintWidget PaintEnv
env Int
idx NodeType
nt rect :: Rect
rect@(Rect Float
_ Float
ry Float
_ Float
rh) = do
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
  style <- Context -> NodeType -> Int -> IO Style
widgetVisualStyle Context
ctx NodeType
nt Int
idx
  value <- getNodeValue (peNodeArena env) idx
  si <- getStyleIdx (peNodeArena env) idx
  -- Menu rows paint edge-to-edge across the popup panel, exactly like the
  -- text-field context menu painter: the hover fill and the accent marker
  -- span the panel width instead of the (padded) node rect.
  menuRowRect <-
    if nt == NodeButton && isMenuItemStyle si
      then maybe rect (\(Rect Float
px Float
_ Float
pw Float
_) -> Float -> Float -> Float -> Float -> Rect
Rect Float
px Float
ry Float
pw Float
rh) <$> popupPanelRect ctx idx
      else pure rect
  paintWidgetBackground env idx nt style si menuRowRect value rect
  paintWidgetForeground env idx nt style si rect

-- The button kind flags are re-derived here from the style bits rather than
-- passed in: a flags record crossing this NOINLINE seam would be allocated
-- for every widget on every painted frame.
{-# NOINLINE paintWidgetBackground #-}
paintWidgetBackground :: PaintEnv -> NodeIdx -> NodeType -> Style -> Int -> Rect -> Float -> Rect -> IO ()
paintWidgetBackground :: PaintEnv
-> Int
-> NodeType
-> Style
-> Int
-> Rect
-> Float
-> Rect
-> IO ()
paintWidgetBackground PaintEnv
env Int
idx NodeType
nt Style
style Int
si Rect
menuRowRect Float
value (Rect Float
x Float
y Float
w Float
h) = do
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
      fm :: FontMetrics
fm = PaintEnv -> FontMetrics
peFontMetrics PaintEnv
env
      theme :: Theme
theme = PaintEnv -> Theme
peTheme PaintEnv
env
      -- Strict: lazy Bools here would allocate thunks per widget per frame.
      !isButton :: Bool
isButton = NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeButton
      !isClose :: Bool
isClose = Bool
isButton Bool -> Bool -> Bool
&& Int -> Bool
isCloseButtonStyle Int
si
      !isTab :: Bool
isTab = Bool
isButton Bool -> Bool -> Bool
&& Int -> Bool
isTabButtonStyle Int
si
      !isTable :: Bool
isTable = Bool
isButton Bool -> Bool -> Bool
&& Int -> Bool
isTableHeaderStyle Int
si
      !isMenuItem :: Bool
isMenuItem = Bool
isButton Bool -> Bool -> Bool
&& Int -> Bool
isMenuItemStyle Int
si
      !isMenu :: Bool
isMenu = Bool
isMenuItem Bool -> Bool -> Bool
|| (Bool
isButton Bool -> Bool -> Bool
&& Int -> Bool
isMenuBarStyle Int
si)
      !hasBg :: Bool
hasBg = Color -> Word8
colorA (Style -> Color
styleBg Style
style) Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0
      !opaqueBg :: Bool
opaqueBg
        | Bool
isMenu = Bool
hasBg
        | Bool
isClose Bool -> Bool -> Bool
|| Bool
isTab = Bool
False
        | Bool
isTable Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTree = Bool
hasBg
        | Bool
otherwise =
            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
&& NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeType
NodeTextInput Bool -> Bool -> Bool
&& NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeType
NodeTextArea Bool -> Bool -> Bool
&& NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeType
NodeColorPicker
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
opaqueBg (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DrawArena -> Style -> Rect -> IO ()
fillStyledRect DrawArena
da Style
style Rect
menuRowRect
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
opaqueBg Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
isTab Bool -> Bool -> Bool
|| Bool
isTable Bool -> Bool -> Bool
|| Bool
isMenu) Bool -> Bool -> Bool
&& NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeType
NodeTree) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DrawArena -> Style -> Rect -> IO ()
strokeStyledRect DrawArena
da Style
style (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isMenuItem (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
    hot <- readIORef (ctxHotId ctx)
    -- Same marker as the text-field context menu, from the shared menu
    -- metrics, so the two painters cannot drift.
    when (wid == hot) $ paintMenuAccent da theme menuRowRect
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTab (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DrawArena
-> Theme
-> Int
-> Bool
-> Style
-> Float
-> Float
-> Float
-> Float
-> IO ()
paintTabHeader DrawArena
da Theme
theme (Int -> Int
buttonVisualStyle Int
si Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4) (Float
value Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5) Style
style Float
x Float
y Float
w Float
h
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTable (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DrawArena
-> Theme
-> Bool
-> Style
-> Float
-> Float
-> Float
-> Float
-> IO ()
paintTableHeader DrawArena
da Theme
theme (Float
value Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5) Style
style Float
x Float
y Float
w Float
h
  case NodeType
nt of
    NodeType
NodeCheckbox -> DrawArena
-> FontMetrics
-> Style
-> Float
-> Float
-> Float
-> Float
-> Color
-> Color
-> Color
-> IO ()
drawCheckbox DrawArena
da FontMetrics
fm Style
style Float
x Float
y Float
h Float
value (Theme -> Color
themeAccent Theme
theme) (Style -> Color
styleBg (Theme -> Style
themeInput Theme
theme)) (Theme -> Color
themeOnAccent Theme
theme)
    NodeType
NodeRadio -> DrawArena
-> FontMetrics
-> Style
-> Float
-> Float
-> Float
-> Float
-> Color
-> Color
-> IO ()
drawRadio DrawArena
da FontMetrics
fm Style
style Float
x Float
y Float
h Float
value (Theme -> Color
themeAccent Theme
theme) (Style -> Color
styleBg (Theme -> Style
themeInput Theme
theme))
    NodeType
NodeTree -> do
      let (Int
_, Int
depth, Bool
hasKids, Bool
expanded) = Int -> (Int, Int, Bool, Bool)
treeDecodeStyle Int
si
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasKids (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        DrawArena
-> FontMetrics
-> Float
-> Float
-> Float
-> Float
-> Int
-> Bool
-> Color
-> IO ()
drawTreeChevron DrawArena
da FontMetrics
fm Float
x Float
y Float
w Float
h Int
depth Bool
expanded (Style -> Color
styleFg Style
style)
    NodeType
NodeSlider -> PaintEnv -> Float -> Float -> Float -> Float -> Float -> IO ()
paintSliderBody PaintEnv
env Float
x Float
y Float
w Float
h Float
value
    NodeType
NodeButton -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isClose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DrawArena
-> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()
drawCloseIcon DrawArena
da (Int -> Int
buttonVisualStyle Int
si Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
buttonCloseTrailing) Float
x Float
y Float
w Float
h (Style -> Color
styleFg Style
style)
    NodeType
NodeSelect -> DrawArena
-> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()
drawSelectChevron DrawArena
da Bool
False Float
x Float
y Float
w Float
h (Style -> Color
styleFg Style
style)
    NodeType
NodeColorPicker -> do
      store <- Context -> IO WidgetStore
getStore Context
ctx
      drawColorPickerPart (peNodeArena env) idx fm da store style (Rect x y w h)
    NodeType
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-# NOINLINE paintSliderBody #-}
paintSliderBody :: PaintEnv -> Float -> Float -> Float -> Float -> Float -> IO ()
paintSliderBody :: PaintEnv -> Float -> Float -> Float -> Float -> Float -> IO ()
paintSliderBody PaintEnv
env Float
x Float
y Float
w Float
h Float
value = do
  let da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
      theme :: Theme
theme = PaintEnv -> Theme
peTheme PaintEnv
env
      track :: Rect
track@(Rect Float
tx Float
ty Float
tw Float
th) = Float -> Float -> Float -> Float -> Rect
sliderTrackBounds Float
x Float
y Float
w Float
h
      trackR :: Float
trackR = Float
3
      fillW :: Float
fillW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
tw Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
clamp01 Float
value)
      outline :: Color
outline = Style -> Color
styleBorder (Theme -> Style
themeInput Theme
theme)
      well :: Color
well = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleBg (Theme -> Style
themeInput Theme
theme)) Color
outline Float
0.35
      bw :: Float
bw = Float
1
      innerR :: Float
innerR = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
trackR Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
bw)
      innerX :: Float
innerX = Float
tx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
bw
      innerY :: Float
innerY = Float
ty Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
bw
      innerW :: Float
innerW = Float
tw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
bw
      innerH :: Float
innerH = Float
th Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
bw
      innerFillW :: Float
innerFillW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
innerW Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
clamp01 Float
value)
  DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
track Float
trackR Float
bw Color
outline
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
innerW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Float
innerH Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
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
innerX Float
innerY Float
innerW Float
innerH) Float
innerR Color
well
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
innerFillW 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 fillR :: Float
fillR =
          if Float
innerFillW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
innerW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
0.5
            then Float
innerR
            else Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
innerR (Float
innerFillW Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
    DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
innerX Float
innerY Float
innerFillW Float
innerH) Float
fillR (Theme -> Color
themeAccent Theme
theme)
  let handleD :: Float
handleD = Float
sliderHandleDiameter
      handleCx :: Float
handleCx = Float
tx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float
handleD Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
tw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
handleD Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
fillW)
      handleHy :: Float
handleHy = Float
ty Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
th Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
handleD) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      innerD :: Float
innerD = Float
handleD Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2
  DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect
    DrawArena
da
    (Float -> Float -> Float -> Float -> Rect
Rect (Float
handleCx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
innerD Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
handleHy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
handleD Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
innerD) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
innerD Float
innerD)
    (Float
innerD Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
    (Theme -> Color
themeOnAccent Theme
theme)
  DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect (Float
handleCx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
handleD Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
handleHy Float
handleD Float
handleD) (Float
handleD Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
bw Color
outline

{-# NOINLINE paintWidgetForeground #-}
paintWidgetForeground :: PaintEnv -> NodeIdx -> NodeType -> Style -> Int -> Rect -> IO ()
paintWidgetForeground :: PaintEnv -> Int -> NodeType -> Style -> Int -> Rect -> IO ()
paintWidgetForeground PaintEnv
env Int
idx NodeType
nt Style
style Int
si (Rect Float
x Float
y Float
w Float
h) = do
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
  mFontColor <- NodeArena -> Int -> IO (Maybe Color)
getNodeFontColor (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  fontSize <- getNodeFontSize (peNodeArena env) idx
  (fm, _, _) <- resolveFontFor ctx nt fontSize si
  let widgetFg = Color -> Maybe Color -> Color
forall a. a -> Maybe a -> a
fromMaybe (Style -> Color
styleFg Style
style) Maybe Color
mFontColor
      sortMark = if NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeButton Bool -> Bool -> Bool
&& Int -> Bool
isTableHeaderStyle Int
si then Int -> Int
tableSortMarkOf Int
si else Int
0
      -- Table sort arrow: pinned to the header's right edge, inside the cell
      -- inset, whatever the label's alignment. The label still ends in a
      -- blank reserve slot (the ▲/▼ codepoint is not in the pruned UI font),
      -- which keeps the column wide enough for the text and the arrow.
      sortArrowX = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
tableCellInset Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
5
      drawPlacement Bool
lastLine Text
txt Float
px Float
py Float
_ Float
th =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
txt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          DrawArena
-> FontMetrics -> Float -> Float -> Text -> Color -> IO ()
pushText DrawArena
da FontMetrics
fm Float
px Float
py Text
txt Color
widgetFg
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sortMark Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Bool
lastLine) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            DrawArena -> Float -> Float -> Bool -> Color -> IO ()
drawSortTriangle DrawArena
da Float
sortArrowX (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
th Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Int
sortMark Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) Color
widgetFg
  forWidgetTextPlacements_ ctx nt idx x y w h drawPlacement

-- | Sort direction triangle for a table header: up when ascending, down when
-- descending, centered on the label line in the header's reserved slot.
drawSortTriangle :: DrawArena -> Float -> Float -> Bool -> Color -> IO ()
drawSortTriangle :: DrawArena -> Float -> Float -> Bool -> Color -> IO ()
drawSortTriangle DrawArena
da Float
cx Float
cy Bool
down Color
col =
  if Bool
down
    then DrawArena
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> IO ()
pushFilledTriangle DrawArena
da (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
5) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
3.5) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
5) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
3.5) Float
cx (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
3.5) Color
col
    else DrawArena
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> IO ()
pushFilledTriangle DrawArena
da (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
5) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
3.5) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
5) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
3.5) Float
cx (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
3.5) Color
col

-- | Draw a single-line field's text, and its selection and caret while it is
-- being edited, inside @clip@. @penX/penY@ locate @txt@ (absolute).
{-# INLINE paintClippedFieldText #-}
paintClippedFieldText ::
  Context ->
  DrawArena ->
  FontMetrics ->
  Style ->
  NodeIdx ->
  Maybe FieldEdit ->
  Rect ->
  Float ->
  Float ->
  T.Text ->
  Color ->
  IO ()
paintClippedFieldText :: Context
-> DrawArena
-> FontMetrics
-> Style
-> Int
-> Maybe FieldEdit
-> Rect
-> Float
-> Float
-> Text
-> Color
-> IO ()
paintClippedFieldText Context
ctx DrawArena
da FontMetrics
fm Style
style Int
idx Maybe FieldEdit
mEdit Rect
clip Float
penX Float
penY Text
txt Color
fg =
  DrawArena -> Rect -> IO () -> IO ()
forall a. DrawArena -> Rect -> IO a -> IO a
withClip DrawArena
da Rect
clip (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (FieldEdit -> IO ()) -> Maybe FieldEdit -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DrawArena -> Context -> Int -> FieldEdit -> IO ()
drawTextInputSelection DrawArena
da Context
ctx Int
idx) Maybe FieldEdit
mEdit
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
txt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      DrawArena
-> FontMetrics -> Float -> Float -> Text -> Color -> IO ()
pushText DrawArena
da FontMetrics
fm Float
penX Float
penY Text
txt Color
fg
    (FieldEdit -> IO ()) -> Maybe FieldEdit -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\FieldEdit
edit -> DrawArena -> FieldEdit -> Color -> IO ()
drawTextInputCaret DrawArena
da FieldEdit
edit (Style -> Color
styleFg Style
style)) Maybe FieldEdit
mEdit

-- | A caption-less field's value, or @placeholder@ (dimmed) while empty and
-- unfocused, scrolled to keep the caret in @clip@.
paintFieldValue :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> Rect -> T.Text -> T.Text -> IO ()
paintFieldValue :: Context
-> DrawArena
-> FontMetrics
-> Style
-> Int
-> Bool
-> Rect
-> Rect
-> Text
-> Text
-> IO ()
paintFieldValue Context
ctx DrawArena
da FontMetrics
fm Style
style Int
idx Bool
focus (Rect Float
x Float
y Float
w Float
h) clip :: Rect
clip@(Rect Float
clipX Float
_ Float
_ Float
_) Text
placeholder Text
value = do
  let display :: Text
display = Text -> Text -> Bool -> Text
textInputFieldText Text
placeholder Text
value Bool
focus
      baseFg :: Color
baseFg = Style -> Color
styleFg Style
style
  scrollX <- Context -> Int -> Float -> Float -> Float -> Float -> IO Float
syncTextInputScroll Context
ctx Int
idx Float
x Float
y Float
w Float
h
  (ty, fg) <-
    if T.null display
      then pure (0, baseFg)
      else do
        (_, th) <- ctxMeasureText ctx display
        pure
          ( centeredTextY fm y h th
          , if T.null value && not focus then lerpColor baseFg (styleBg style) 0.5 else baseFg
          )
  mEdit <- readFieldEdit ctx idx x y w h scrollX
  paintClippedFieldText ctx da fm style idx mEdit clip (clipX - scrollX) ty display fg

-- | Numeric field: the box, its value clipped left of the stepper, and the
-- stepper's up and down arrows beside a rule.
paintNumericField :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> IO ()
paintNumericField :: Context
-> DrawArena
-> FontMetrics
-> Style
-> Int
-> Bool
-> Rect
-> IO ()
paintNumericField Context
ctx DrawArena
da FontMetrics
fm Style
style Int
idx Bool
focus box :: Rect
box@(Rect Float
x Float
y Float
w Float
h) = do
  DrawArena -> Style -> Rect -> IO ()
paintStyledRect DrawArena
da Style
style Rect
box
  value <- Context -> Int -> IO Text
textInputValue Context
ctx Int
idx
  let (up@(Rect ux _ _ _), down) = numericStepperRects x y w h
      iconCol = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleFg Style
style) (Style -> Color
styleBg Style
style) Float
0.4
      ruleCol = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleBorder Style
style) (Style -> Color
styleBg Style
style) Float
0.4
  pushLine da ux (y + 4) ux (y + h - 4) 1 ruleCol
  drawStepArrow da True up iconCol
  drawStepArrow da False down iconCol
  paintFieldValue ctx da fm style idx focus box (numericTextClip fm x y w h) "" value

-- | A stepper arrow in its half of the stepper, nudged toward the other half so
-- the pair reads as one control.
drawStepArrow :: DrawArena -> Bool -> Rect -> Color -> IO ()
drawStepArrow :: DrawArena -> Bool -> Rect -> Color -> IO ()
drawStepArrow DrawArena
da Bool
up (Rect Float
sx Float
sy Float
sw Float
sh) Color
col = do
  let cx :: Float
cx = Float
sx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
sw Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      cy :: Float
cy = Float
sy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
sh Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (if Bool
up then Float
1 else -Float
1)
      hw :: Float
hw = Float
3.6
      tip :: Float
tip = if Bool
up then -Float
2.4 else Float
2.4
  DrawArena
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> IO ()
pushFilledTriangle DrawArena
da (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
tip Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.35) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
tip Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.35) Float
cx (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
tip) Color
col

-- | Caption-less search field: box fills the node rect, magnifier on the left,
-- clear (×) on the right when there is text, and the editable value / caret /
-- selection confined to the space between them.
paintSearchField :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> IO ()
paintSearchField :: Context
-> DrawArena
-> FontMetrics
-> Style
-> Int
-> Bool
-> Rect
-> IO ()
paintSearchField Context
ctx DrawArena
da FontMetrics
fm Style
style Int
idx Bool
focus box :: Rect
box@(Rect Float
x Float
y Float
w Float
h) = do
  let (Rect
magRect, Rect Float
cx Float
cy Float
cw Float
ch) = FontMetrics -> Float -> Float -> Float -> Float -> (Rect, Rect)
searchFieldIconRects FontMetrics
fm Float
x Float
y Float
w Float
h
      iconCol :: Color
iconCol = Color -> Color -> Float -> Color
lerpColor (Style -> Color
styleFg Style
style) (Style -> Color
styleBg Style
style) Float
0.45
  DrawArena -> Style -> Rect -> IO ()
paintStyledRect DrawArena
da Style
style Rect
box
  value <- Context -> Int -> IO Text
textInputValue Context
ctx Int
idx
  lbl <- getText (ctxNodeArena ctx) idx
  drawSearchMagnifier da magRect iconCol
  paintFieldValue ctx da fm style idx focus box (searchFieldTextClip fm x y w h) lbl value
  unless (T.null value) $
    drawCloseIcon da False cx cy cw ch iconCol

-- | Selectable text: chrome-less, border-less, naturally sized text field
-- that supports mouse drag selection and text copying without an insertion caret.
paintSelectableText :: PaintEnv -> Style -> NodeIdx -> Rect -> IO ()
paintSelectableText :: PaintEnv -> Style -> Int -> Rect -> IO ()
paintSelectableText PaintEnv
env Style
style Int
idx rect :: Rect
rect@(Rect Float
x Float
y Float
w Float
h) = do
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
      arena :: NodeArena
arena = PaintEnv -> NodeArena
peNodeArena PaintEnv
env
  si <- NodeArena -> Int -> IO Int
getStyleIdx NodeArena
arena Int
idx
  mFontColor <- getNodeFontColor arena idx
  fontSize <- getNodeFontSize arena idx
  (fm, _, _) <- resolveFontFor ctx NodeTextInput fontSize si
  value <- textInputValue ctx idx
  let (penX, ty, _) = selectableTextGeometry fm x y h
  mEdit <- readFieldEdit ctx idx x y w h 0
  withClip da rect $ do
    mapM_ (drawTextInputSelection da ctx idx) mEdit
    unless (T.null value) $
      pushText da fm penX ty value (fromMaybe (styleFg style) mFontColor)

drawSearchMagnifier :: DrawArena -> Rect -> Color -> IO ()
drawSearchMagnifier :: DrawArena -> Rect -> Color -> IO ()
drawSearchMagnifier DrawArena
da (Rect Float
x Float
y Float
w Float
h) Color
col = do
  let cx :: Float
cx = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      cy :: Float
cy = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      s :: Float
s = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
w Float
h
      r0 :: Float
r0 = Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.36
      t :: Float
t = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.4 (Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.15)
      startOff :: Float
startOff = Float
r0 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.7071
      endOff :: Float
endOff = Float
r0 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.7071 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.22
  DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
r0) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
r0) (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
r0) (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
r0)) Float
r0 Float
t Color
col
  DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushLine DrawArena
da (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
startOff) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
startOff) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
endOff) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
endOff) (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.8) Color
col

-- | Combo box field: the search field's full-rect editable box, but styled
-- like a dropdown: no magnifier or clear chrome, and a select chevron in the
-- right reserve that flips up while the dropdown is open (i.e. focused).
paintComboField :: Context -> DrawArena -> FontMetrics -> Style -> NodeIdx -> Bool -> Rect -> IO ()
paintComboField :: Context
-> DrawArena
-> FontMetrics
-> Style
-> Int
-> Bool
-> Rect
-> IO ()
paintComboField Context
ctx DrawArena
da FontMetrics
fm Style
style Int
idx Bool
focus box :: Rect
box@(Rect Float
x Float
y Float
w Float
h) = do
  DrawArena -> Style -> Rect -> IO ()
paintStyledRect DrawArena
da Style
style Rect
box
  value <- Context -> Int -> IO Text
textInputValue Context
ctx Int
idx
  lbl <- getText (ctxNodeArena ctx) idx
  drawSelectChevron
    da
    focus
    (x + w - selectChevronReserve)
    y
    selectChevronReserve
    h
    (lerpColor (styleFg style) (styleBg style) 0.45)
  paintFieldValue ctx da fm style idx focus box (comboTextClip fm x y w h) lbl value

verticallyCenteredBox :: Float -> Float -> Float -> Float
verticallyCenteredBox :: Float -> Float -> Float -> Float
verticallyCenteredBox Float
y Float
h Float
box =
  let slotH :: Float
slotH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
h (Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
4)
   in Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 ((Float
slotH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
box) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)

drawChoiceControl ::
  DrawArena ->
  FontMetrics ->
  Style ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Color ->
  Color ->
  Bool ->
  (Float -> Float -> Float -> IO ()) ->
  IO ()
drawChoiceControl :: DrawArena
-> FontMetrics
-> Style
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> Color
-> Bool
-> (Float -> Float -> Float -> IO ())
-> IO ()
drawChoiceControl DrawArena
da FontMetrics
fm Style
style Float
x Float
y Float
h Float
r Float
bw Float
value Color
accent Color
well Bool
solidChecked Float -> Float -> Float -> IO ()
postMark = do
  let box :: Float
box = FontMetrics -> Float
checkboxBoxSize FontMetrics
fm
      bx :: Float
bx = Float
x
      by :: Float
by = Float -> Float -> Float -> Float
verticallyCenteredBox Float
y Float
h Float
box
      outer :: Rect
outer = Float -> Float -> Float -> Float -> Rect
Rect Float
bx Float
by Float
box Float
box
      checked :: Bool
checked = Float
value Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
0.5
  if Bool
checked Bool -> Bool -> Bool
&& Bool
solidChecked
    then do
      DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
outer Float
r Color
accent
      DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
outer Float
r Float
bw Color
accent
      Float -> Float -> Float -> IO ()
postMark Float
bx Float
by Float
box
    else do
      let inner :: Rect
inner = Float -> Float -> Float -> Float -> Rect
Rect (Float
bx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
bw) (Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
bw) (Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
bw) (Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
bw)
          innerR :: Float
innerR = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
bw)
          strokeCol :: Color
strokeCol = if Bool
checked then Color
accent else Style -> Color
styleBorder Style
style
      DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
inner Float
innerR Color
well
      DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
outer Float
r Float
bw Color
strokeCol
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> IO ()
postMark Float
bx Float
by Float
box

drawCheckbox :: DrawArena -> FontMetrics -> Style -> Float -> Float -> Float -> Float -> Color -> Color -> Color -> IO ()
drawCheckbox :: DrawArena
-> FontMetrics
-> Style
-> Float
-> Float
-> Float
-> Float
-> Color
-> Color
-> Color
-> IO ()
drawCheckbox DrawArena
da FontMetrics
fm Style
style Float
x Float
y Float
h Float
value Color
accent Color
well Color
mark =
  let box :: Float
box = FontMetrics -> Float
checkboxBoxSize FontMetrics
fm
      r :: Float
r = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
6 (Float
box Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3.5)
      bw :: Float
bw = Float
1.5
   in DrawArena
-> FontMetrics
-> Style
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> Color
-> Bool
-> (Float -> Float -> Float -> IO ())
-> IO ()
drawChoiceControl DrawArena
da FontMetrics
fm Style
style Float
x Float
y Float
h Float
r Float
bw Float
value Color
accent Color
well Bool
True ((Float -> Float -> Float -> IO ()) -> IO ())
-> (Float -> Float -> Float -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Float
bx Float
by Float
b ->
        DrawArena -> Float -> Float -> Float -> Color -> IO ()
drawCheckboxMark DrawArena
da Float
bx Float
by Float
b Color
mark

drawCheckboxMark :: DrawArena -> Float -> Float -> Float -> Color -> IO ()
drawCheckboxMark :: DrawArena -> Float -> Float -> Float -> Color -> IO ()
drawCheckboxMark DrawArena
da Float
bx Float
by Float
box Color
markCol = do
  let t :: Float
t = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.6 (Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.11)
      x0 :: Float
x0 = Float
bx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.22
      y0 :: Float
y0 = Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.52
      x1 :: Float
x1 = Float
bx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.42
      y1 :: Float
y1 = Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.72
      x2 :: Float
x2 = Float
bx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.78
      y2 :: Float
y2 = Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
box Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.28
      -- Caps snap their centres, as the strokes snap their ends; snapping a
      -- cap's corner lands it up to a pixel off the stroke at a fractional
      -- scale.
      cap :: Float -> Float -> IO ()
cap Float
cx Float
cy = DrawArena -> Float -> Float -> Float -> Color -> IO ()
pushCircle DrawArena
da Float
cx Float
cy (Float
t Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Color
markCol
  DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushStrokeAA DrawArena
da Float
x0 Float
y0 Float
x1 Float
y1 Float
t Color
markCol
  DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushStrokeAA DrawArena
da Float
x1 Float
y1 Float
x2 Float
y2 Float
t Color
markCol
  Float -> Float -> IO ()
cap Float
x0 Float
y0
  Float -> Float -> IO ()
cap Float
x1 Float
y1
  Float -> Float -> IO ()
cap Float
x2 Float
y2

drawRadio :: DrawArena -> FontMetrics -> Style -> Float -> Float -> Float -> Float -> Color -> Color -> IO ()
drawRadio :: DrawArena
-> FontMetrics
-> Style
-> Float
-> Float
-> Float
-> Float
-> Color
-> Color
-> IO ()
drawRadio DrawArena
da FontMetrics
fm Style
style Float
x Float
y Float
h Float
value Color
accent Color
well =
  let box :: Float
box = FontMetrics -> Float
checkboxBoxSize FontMetrics
fm
      r :: Float
r = Float
box Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      bw :: Float
bw = Float
2
   in DrawArena
-> FontMetrics
-> Style
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> Color
-> Bool
-> (Float -> Float -> Float -> IO ())
-> IO ()
drawChoiceControl DrawArena
da FontMetrics
fm Style
style Float
x Float
y Float
h Float
r Float
bw Float
value Color
accent Color
well Bool
False ((Float -> Float -> Float -> IO ()) -> IO ())
-> (Float -> Float -> Float -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Float
bx Float
by Float
b -> do
        s <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Float
daSnapScale DrawArena
da)
        let !dot = Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.72
            !dx = Float -> Float -> Float
onGrid Float
s Float
bx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dot) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
            !dy = Float -> Float -> Float
onGrid Float
s Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dot) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
        pushRoundedRectRaw da (Rect dx dy dot dot) (dot / 2) accent

-- | A cross centered in the box, or against its right edge when @trailing@.
drawCloseIcon :: DrawArena -> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()
drawCloseIcon :: DrawArena
-> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()
drawCloseIcon DrawArena
da Bool
trailing Float
x Float
y Float
w Float
h Color
col = do
  let arm :: Float
arm = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
w Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.21
      t :: Float
t = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.3 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
w Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.064)
      cx :: Float
cx = if Bool
trailing then Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
arm Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
t Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2 else Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      cy :: Float
cy = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
  DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushLine DrawArena
da (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
arm) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
arm) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
arm) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
arm) Float
t Color
col
  DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushLine DrawArena
da (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
arm) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
arm) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
arm) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
arm) Float
t Color
col

-- | Select chevron centered in the right reserve of @x w@; points up when
-- @up@ (an open combo dropdown), down otherwise.
drawSelectChevron :: DrawArena -> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()
drawSelectChevron :: DrawArena
-> Bool -> Float -> Float -> Float -> Float -> Color -> IO ()
drawSelectChevron DrawArena
da Bool
up Float
x Float
y Float
w Float
h Color
col = do
  let cx :: Float
cx = Float -> Float -> Float
selectChevronCenterX Float
x Float
w
      cy :: Float
cy = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      hw :: Float
hw = Float
4.2
      tip :: Float
tip = if Bool
up then -Float
2.6 else Float
2.6
  DrawArena
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> IO ()
pushFilledTriangle DrawArena
da (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
tip Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.35) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
tip Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.35) Float
cx (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
tip) Color
col

drawTreeChevron :: DrawArena -> FontMetrics -> Float -> Float -> Float -> Float -> Int -> Bool -> Color -> IO ()
drawTreeChevron :: DrawArena
-> FontMetrics
-> Float
-> Float
-> Float
-> Float
-> Int
-> Bool
-> Color
-> IO ()
drawTreeChevron DrawArena
da FontMetrics
fm Float
x Float
y Float
w Float
h Int
depth Bool
expanded Color
col = do
  let Rect Float
cx Float
cy Float
cw Float
ch = FontMetrics -> Float -> Float -> Float -> Float -> Int -> Rect
treeChevronRect FontMetrics
fm Float
x Float
y Float
w Float
h Int
depth
      mx :: Float
mx = Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cw Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      my :: Float
my = Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ch Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      s :: Float
s = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
4.5 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
cw Float
ch Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.28)
      t :: Float
t = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.0 (Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.16)
  if Bool
expanded
    then do
      DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushLine DrawArena
da (Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s) (Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.45) Float
mx (Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.7) Float
t Color
col
      DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushLine DrawArena
da Float
mx (Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.7) (Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s) (Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.45) Float
t Color
col
    else do
      DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushLine DrawArena
da (Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.45) (Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s) (Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.7) Float
my Float
t Color
col
      DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushLine DrawArena
da (Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.7) Float
my (Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.45) (Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s) Float
t Color
col