{-# LANGUAGE DataKinds #-}

module NanoUI.Frame.Spans
  ( collectTextSpans
  , collectOverlayTextSpans
  , collectRasterSpans
  , widgetNodeCount
  , widgetHitRect
  , widgetTextSpans
  , forWidgetTextPlacements_
  , selectableTextGeometry
  , collectNodeTextSpans
  ) where

import Control.Monad (forM, unless, when)
import Data.IORef (readIORef, writeIORef)
import qualified Data.IntMap.Strict as IM
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import NanoUI.Context
  ( Context (..)
  , SpanCacheEntry (..)
  , WidgetTextCacheEntry (..)
  , WidgetTextPlacement (..)
  , nodeTheme
  )
import NanoUI.Damage (floatingPanelRects)
import NanoUI.Font
  ( FontMetrics (..)
  , alignedTextPen
  , centeredTextY
  , checkboxLeading
  , menuItemPadX
  , prepareFontMetrics
  , tableCellInset
  , treeRowLeading
  , truncateTextIO
  , widgetContentInset
  , wrapTextLinesIO
  )
import NanoUI.Frame.Chrome (displayText, textInputFocused, textInputValue, widgetVisualStyle)
import NanoUI.Frame.Node (readScrollNode, resolveFontFor, scrollNodeViewport)
import NanoUI.Frame.Scroll.Geometry (padContentClip, tagClippedSpans)
import NanoUI.Frame.Select (collectSelectDropdownSpans, tagSelectClippedSpans)
import NanoUI.Frame.SpanArena (SpanArena, pushSpan, resetSpanArena, spanArenaToList, spanArenaToListOccluded)
import NanoUI.Frame.TextEdit.Menu (collectTextEditMenuSpans)
import NanoUI.Frame.TextInput (syncTextInputScroll, tagTextInputClippedSpans, textInputFieldRect)
import NanoUI.Input (Input)
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (..)
  , SizingTag (..)
  , arenaCount
  , forNodes_
  , getAlignX
  , getClipRect
  , getFirstChild
  , getMinMax
  , getNextSibling
  , getNodeFontColor
  , getNodeFontSize
  , getNodeType
  , getPadding
  , getRect
  , getStyleIdx
  , getText
  , getWidthSizing
  , isFloatingNode
  , isScrollNode
  , hasCenteredLabel
  , isWidgetNode
  , parentIsRow
  )
import NanoUI.Layout.Solve (findAncestorMaxW, textWrapCap)
import NanoUI.Style (AlignX (..), FontVariant (..), Style (..), Theme (..), themeAccent, themeMuted, themePanel)
import NanoUI.Types (Color (..), Rect (..), lerpColor, onGrid, rectIntersect)
import NanoUI.Widgets.ColorPicker (ColorPickerPart (..), colorPickerPartOf, colorPickerPartRect, colorPickerPreviewGeom)
import NanoUI.WidgetText
  ( colorPickerCurrentLabel
  , colorPickerNewLabel
  , isCloseButtonStyle
  , isMenuItemStyle
  , isTableHeaderStyle
  , numericTextClip
  , selectChevronReserve
  , tableStripeColor
  , textInputNumericMode
  , textInputFieldText
  , textInputSearchMode
  , textInputSelectableMode
  , textNodeFontVariant
  , treeDecodeStyle
  )

collectTextSpans :: Context -> IO [(Rect, T.Text, Color, Color, Rect)]
collectTextSpans :: Context -> IO [(Rect, Text, Color, Color, Rect)]
collectTextSpans Context
ctx = do
  count <- NodeArena -> IO Int
arenaCount (Context -> NodeArena
ctxNodeArena Context
ctx)
  let arena = Context -> SpanArena
ctxSpanBase Context
ctx
  resetSpanArena arena
  when (count > 0) $
    collectClippedSpans ctx 0 (Rect 0 0 1e9 1e9) arena
  panels <- floatingPanelRects ctx
  spanArenaToListOccluded panels arena

collectOverlayTextSpans :: Context -> Input -> IO [(Rect, T.Text, Color, Color, Rect)]
collectOverlayTextSpans :: Context -> Input -> IO [(Rect, Text, Color, Color, Rect)]
collectOverlayTextSpans Context
ctx Input
inp = do
  let arena :: SpanArena
arena = Context -> SpanArena
ctxSpanOverlay Context
ctx
      push :: (Rect, Text, Color, Color, Rect) -> IO ()
push (Rect
r, Text
t, Color
fg, Color
bg, Rect
c) = SpanArena -> Rect -> Text -> Color -> Color -> Rect -> IO ()
pushSpan SpanArena
arena Rect
r Text
t Color
fg Color
bg Rect
c
  SpanArena -> IO ()
resetSpanArena SpanArena
arena
  Context -> NodeType -> SpanArena -> IO ()
collectFloatingSpansInto Context
ctx NodeType
NodeWindow SpanArena
arena
  Context -> NodeType -> SpanArena -> IO ()
collectFloatingSpansInto Context
ctx NodeType
NodeModal SpanArena
arena
  Context -> NodeType -> SpanArena -> IO ()
collectFloatingSpansInto Context
ctx NodeType
NodePopup SpanArena
arena
  drops <- Context -> Input -> IO [(Rect, Text, Color, Color, Rect)]
collectSelectDropdownSpans Context
ctx Input
inp
  menu <- collectTextEditMenuSpans ctx inp
  mapM_ push drops
  mapM_ push menu
  spanArenaToList arena

collectRasterSpans :: Context -> Input -> IO ([(Rect, T.Text, Color, Color, Rect)], [(Rect, T.Text, Color, Color, Rect)])
collectRasterSpans :: Context
-> Input
-> IO
     ([(Rect, Text, Color, Color, Rect)],
      [(Rect, Text, Color, Color, Rect)])
collectRasterSpans Context
ctx Input
inp = (,) ([(Rect, Text, Color, Color, Rect)]
 -> [(Rect, Text, Color, Color, Rect)]
 -> ([(Rect, Text, Color, Color, Rect)],
     [(Rect, Text, Color, Color, Rect)]))
-> IO [(Rect, Text, Color, Color, Rect)]
-> IO
     ([(Rect, Text, Color, Color, Rect)]
      -> ([(Rect, Text, Color, Color, Rect)],
          [(Rect, Text, Color, Color, Rect)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO [(Rect, Text, Color, Color, Rect)]
collectTextSpans Context
ctx IO
  ([(Rect, Text, Color, Color, Rect)]
   -> ([(Rect, Text, Color, Color, Rect)],
       [(Rect, Text, Color, Color, Rect)]))
-> IO [(Rect, Text, Color, Color, Rect)]
-> IO
     ([(Rect, Text, Color, Color, Rect)],
      [(Rect, Text, Color, Color, Rect)])
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Context -> Input -> IO [(Rect, Text, Color, Color, Rect)]
collectOverlayTextSpans Context
ctx Input
inp

widgetNodeCount :: Context -> IO Int
widgetNodeCount :: Context -> IO Int
widgetNodeCount Context
ctx = NodeArena -> IO Int
arenaCount (Context -> NodeArena
ctxNodeArena Context
ctx)

{-# INLINE collectClippedSpans #-}
collectClippedSpans :: Context -> NodeIdx -> Rect -> SpanArena -> IO ()
collectClippedSpans :: Context -> Int -> Rect -> SpanArena -> IO ()
collectClippedSpans Context
ctx Int
idx Rect
clip SpanArena
arena = do
  nt <- NodeArena -> Int -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  unless (isFloatingNode nt) $
    collectClippedSpans' ctx idx nt clip arena

collectClippedSpans' :: Context -> NodeIdx -> NodeType -> Rect -> SpanArena -> IO ()
collectClippedSpans' :: Context -> Int -> NodeType -> Rect -> SpanArena -> IO ()
collectClippedSpans' Context
ctx Int
idx NodeType
nt Rect
clip SpanArena
arena = do
  (x, y, w, h) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  mClipChildren <-
    if isScrollNode nt
      then
        getClipRect (ctxNodeArena ctx) idx >>= \case
          Just Rect
live -> Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect -> Rect -> Maybe Rect
rectIntersect Rect
clip Rect
live)
          Maybe Rect
Nothing -> (\ScrollNode
sn -> Rect -> Rect -> Maybe Rect
rectIntersect Rect
clip (ScrollNode -> Float -> Float -> Float -> Float -> Rect
scrollNodeViewport ScrollNode
sn Float
x Float
y Float
w Float
h)) (ScrollNode -> Maybe Rect) -> IO ScrollNode -> IO (Maybe Rect)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArena -> Int -> IO ScrollNode
readScrollNode (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      else pure (if nt == NodePanel then rectIntersect clip (Rect x y w h) else Just clip)
  case mClipChildren of
    Maybe Rect
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Rect
clipHere -> do
      let fm :: FontMetrics
fm = Context -> FontMetrics
ctxFontMetrics Context
ctx
      spans <- Context -> Int -> IO [(Rect, Text, Color, Color)]
collectNodeTextSpans Context
ctx Int
idx
      here <-
        case nt of
          NodeType
NodeSelect -> [(Rect, Text, Color, Color, Rect)]
-> IO [(Rect, Text, Color, Color, Rect)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect
-> Float
-> Float
-> Float
-> Float
-> FontMetrics
-> [(Rect, Text, Color, Color)]
-> [(Rect, Text, Color, Color, Rect)]
tagSelectClippedSpans Rect
clipHere Float
x Float
y Float
w Float
h FontMetrics
fm [(Rect, Text, Color, Color)]
spans)
          NodeType
NodeTextInput -> do
            si <- NodeArena -> Int -> IO Int
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
            pure $
              if textInputNumericMode si
                then maybe [] (`tagClippedSpans` spans) (rectIntersect clipHere (numericTextClip fm x y w h))
                else
                  if textInputSelectableMode si
                    then tagClippedSpans clipHere spans
                    else tagTextInputClippedSpans clipHere x y w h fm spans
          NodeType
_ -> [(Rect, Text, Color, Color, Rect)]
-> IO [(Rect, Text, Color, Color, Rect)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect
-> [(Rect, Text, Color, Color)]
-> [(Rect, Text, Color, Color, Rect)]
tagClippedSpans Rect
clipHere [(Rect, Text, Color, Color)]
spans)
      mapM_ (\(Rect
r, Text
t, Color
fg, Color
bg, Rect
c) -> SpanArena -> Rect -> Text -> Color -> Color -> Rect -> IO ()
pushSpan SpanArena
arena Rect
r Text
t Color
fg Color
bg Rect
c) here
      walkChildSpans ctx idx clipHere arena

walkChildSpans :: Context -> NodeIdx -> Rect -> SpanArena -> IO ()
walkChildSpans :: Context -> Int -> Rect -> SpanArena -> IO ()
walkChildSpans Context
ctx Int
idx Rect
clip SpanArena
arena = NodeArena -> Int -> IO Int
getFirstChild (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
go
  where
    go :: Int -> IO ()
go Int
ci
      | Int
ci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          ns <- NodeArena -> Int -> IO Int
getNextSibling (Context -> NodeArena
ctxNodeArena Context
ctx) Int
ci
          -- Later siblings paint under earlier ones; walk reverse then collect.
          go ns
          collectClippedSpans ctx ci clip arena

-- | Text spans of one node. A text node's spans are cached per node until
-- its inputs change. Placement uses glyph ink ('alignedTextPen'), not
-- TTF_GetStringSize; wrapping still measures with the host so line breaks
-- stay on the TTF width.
collectNodeTextSpans :: Context -> NodeIdx -> IO [(Rect, T.Text, Color, Color)]
collectNodeTextSpans :: Context -> Int -> IO [(Rect, Text, Color, Color)]
collectNodeTextSpans Context
ctx Int
idx = do
  let arena :: NodeArena
arena = Context -> NodeArena
ctxNodeArena Context
ctx
  nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
arena Int
idx
  (x, y, w, h) <- getRect arena idx
  if nt /= NodeText
    then if isWidgetNode nt then widgetTextSpans ctx nt idx x y w h else pure []
    else do
      theme <- nodeTheme ctx idx
      raw <- getText arena idx
      si <- getStyleIdx arena idx
      mCustomCol <- getNodeFontColor arena idx
      fontSize <- getNodeFontSize arena idx
      ax <- getAlignX arena idx
      (_, _, maxW, _) <- getMinMax arena idx
      (wTag, _) <- getWidthSizing arena idx
      isRowChild <- parentIsRow arena idx
      effMaxW <- if maxW < 1e8 then pure maxW else findAncestorMaxW arena idx
      let rect = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
          mStripe = Theme -> Int -> Maybe Color
tableStripeColor Theme
theme Int
si
          variantFg = case Int -> FontVariant
textNodeFontVariant Int
si of
            FontVariant
FontHeading -> Theme -> Color
themeAccent Theme
theme
            FontVariant
FontMuted -> Theme -> Color
themeMuted Theme
theme
            FontVariant
FontDanger -> Theme -> Color
themeRed Theme
theme
            FontVariant
_ -> Style -> Color
styleFg (Theme -> Style
themePanel Theme
theme)
          fg = Color -> Maybe Color -> Color
forall a. a -> Maybe a -> a
fromMaybe Color
variantFg Maybe Color
mCustomCol
          bg = Color -> Maybe Color -> Color
forall a. a -> Maybe a -> a
fromMaybe (Style -> Color
styleBg (Theme -> Style
themePanel Theme
theme)) Maybe Color
mStripe
      cache <- readIORef (ctxSpanCache ctx)
      case IM.lookup idx cache of
        Just SpanCacheEntry
e
          | SpanCacheEntry -> Text
sceText SpanCacheEntry
e Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
raw
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Color
sceFg SpanCacheEntry
e Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
fg
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Color
sceBg SpanCacheEntry
e Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
bg
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Int
sceStyle SpanCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
si
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Float
sceFontSize SpanCacheEntry
e Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
fontSize
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Int
sceAlign SpanCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== AlignX -> Int
forall a. Enum a => a -> Int
fromEnum AlignX
ax
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Int
sceWidthTag SpanCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag -> Int
forall a. Enum a => a -> Int
fromEnum SizingTag
wTag
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Rect
sceRect SpanCacheEntry
e Rect -> Rect -> Bool
forall a. Eq a => a -> a -> Bool
== Rect
rect
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Float
sceEffMaxW SpanCacheEntry
e Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
effMaxW
              Bool -> Bool -> Bool
&& SpanCacheEntry -> Bool
sceRowChild SpanCacheEntry
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
isRowChild ->
              [(Rect, Text, Color, Color)] -> IO [(Rect, Text, Color, Color)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanCacheEntry -> [(Rect, Text, Color, Color)]
sceSpans SpanCacheEntry
e)
        Maybe SpanCacheEntry
_ -> do
          placed <-
            if Text -> Bool
T.null Text
raw
              then [(Rect, Text)] -> IO [(Rect, Text)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
              else do
                (fm, _, measure) <- Context
-> NodeType
-> Float
-> Int
-> IO (FontMetrics, Bool, Text -> IO (Float, Float))
resolveFontFor Context
ctx NodeType
NodeText Float
fontSize Int
si
                let ix = if Maybe Color -> Bool
forall a. Maybe a -> Bool
isJust Maybe Color
mStripe then Float
tableCellInset else Float
0
                    measureW = ((Float, Float) -> Float) -> IO (Float, Float) -> IO Float
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Float, Float) -> Float
forall a b. (a, b) -> a
fst (IO (Float, Float) -> IO Float)
-> (Text -> IO (Float, Float)) -> Text -> IO Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO (Float, Float)
measure
                    lineH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
                    contentW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ix)
                    wrapCap = Float -> SizingTag -> Float -> Float
textWrapCap Float
effMaxW SizingTag
wTag Float
w
                tw <- measureW raw
                if T.any (== '\n') raw || (not isRowChild && wrapCap < 1e8 && wrapCap + 0.5 < tw)
                  then do
                    textLines <- wrapTextLinesIO measureW raw (max 0 (wrapCap - 2 * ix))
                    forM (zip [(0 :: Int) ..] textLines) $ \(Int
i, Text
line) -> do
                      prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
line
                      let (tx, used) = alignedTextPen ax x w ix prepared line
                          ty = FontMetrics -> Float -> Float -> Float -> Float
centeredTextY FontMetrics
fm (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
onGrid (FontMetrics -> Float
fmSnapScale FontMetrics
fm) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lineH)) Float
lineH Float
lineH
                      pure (Rect tx ty used lineH, line)
                  else do
                    shown <-
                      if tw > contentW && contentW > 0 && (wTag == SizingGrow || maxW < 1e8)
                        then truncateTextIO measureW contentW raw
                        else pure raw
                    prepared <- prepareFontMetrics fm shown
                    let (tx, used) = alignedTextPen ax x w ix prepared shown
                    pure [(Rect tx (centeredTextY fm y h lineH) used lineH, shown)]
          let spans = [(Rect
r, Text
line, Color
fg, Color
bg) | (Rect
r, Text
line) <- [(Rect, Text)]
placed]
          writeIORef (ctxSpanCache ctx) $
            IM.insert
              idx
              SpanCacheEntry
                { sceText = raw
                , sceFg = fg
                , sceBg = bg
                , sceStyle = si
                , sceFontSize = fontSize
                , sceAlign = fromEnum ax
                , sceWidthTag = fromEnum wTag
                , sceRect = rect
                , sceEffMaxW = effMaxW
                , sceRowChild = isRowChild
                , sceSpans = spans
                }
              cache
          pure spans

widgetHitRect :: Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO Rect
widgetHitRect :: Context
-> NodeType -> Int -> Float -> Float -> Float -> Float -> IO Rect
widgetHitRect Context
ctx NodeType
nt Int
idx Float
x Float
y Float
w Float
h = do
  let fm :: FontMetrics
fm = Context -> FontMetrics
ctxFontMetrics Context
ctx
  case NodeType
nt of
    NodeType
NodeTextInput -> do
      si <- NodeArena -> Int -> IO Int
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      if textInputSearchMode si || textInputSelectableMode si || textInputNumericMode si
        then pure (Rect x y w h)
        else pure (textInputFieldRect fm x y w h)
    NodeType
NodeTextArea -> Rect -> IO Rect
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h)
    NodeType
NodeButton -> do
      si <- NodeArena -> Int -> IO Int
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      -- Close buttons get a padded target that stays inside the title bar, so
      -- the inner east resize still works below the control.
      if isCloseButtonStyle si
        then pure (Rect (x - 8) (y - 4) (w + 10) (h + 4))
        else pure (Rect x y w h)
    NodeType
_ -> Rect -> IO Rect
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h)

widgetTextSpans ::
  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO [(Rect, T.Text, Color, Color)]
widgetTextSpans :: Context
-> NodeType
-> Int
-> Float
-> Float
-> Float
-> Float
-> IO [(Rect, Text, Color, Color)]
widgetTextSpans Context
ctx NodeType
nt Int
idx Float
x Float
y Float
w Float
h = do
  style <- Context -> NodeType -> Int -> IO Style
widgetVisualStyle Context
ctx NodeType
nt Int
idx
  mFontColor <- getNodeFontColor (ctxNodeArena ctx) idx
  placements <- widgetTextPlacements ctx nt idx x y w h
  let fg = Color -> Maybe Color -> Color
forall a. a -> Maybe a -> a
fromMaybe (Style -> Color
styleFg Style
style) Maybe Color
mFontColor
      bg = Style -> Color
styleBg Style
style
  case nt of
    NodeType
NodeTextInput -> do
      value <- Context -> Int -> IO Text
textInputValue Context
ctx Int
idx
      focus <- textInputFocused ctx idx
      let fieldFg = if Text -> Bool
T.null Text
value Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
focus then Color -> Color -> Float -> Color
lerpColor Color
fg Color
bg Float
0.40 else Color
fg
      pure [(Rect px py tw th, txt, fieldFg, bg) | (txt, px, py, tw, th) <- placements]
    NodeType
_ ->
      [(Rect, Text, Color, Color)] -> IO [(Rect, Text, Color, Color)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Float -> Float -> Float -> Float -> Rect
Rect Float
px Float
py Float
tw Float
th, Text
txt, Color
fg, Color
bg) | (Text
txt, Float
px, Float
py, Float
tw, Float
th) <- [(Text, Float, Float, Float, Float)]
placements, Bool -> Bool
not (Text -> Bool
T.null Text
txt)]

-- | Cacheable widget labels depend on text, style, font size, alignment and
-- dimensions, but not the absolute node origin. Text
-- fields / areas / colour pickers / sliders are data-dependent and stay out.
cacheableWidgetLabel :: NodeType -> Bool
cacheableWidgetLabel :: NodeType -> Bool
cacheableWidgetLabel = NodeType -> Bool
hasCenteredLabel

widgetTextPlacements ::
  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO [(T.Text, Float, Float, Float, Float)]
widgetTextPlacements :: Context
-> NodeType
-> Int
-> Float
-> Float
-> Float
-> Float
-> IO [(Text, Float, Float, Float, Float)]
widgetTextPlacements Context
ctx NodeType
nt Int
idx Float
x Float
y Float
w Float
h
  | NodeType -> Bool
cacheableWidgetLabel NodeType
nt = do
      placement <- Context
-> NodeType
-> Int
-> Float
-> Float
-> IO (Maybe WidgetTextPlacement)
cachedWidgetLabel Context
ctx NodeType
nt Int
idx Float
w Float
h
      pure [(txt, x + px, y + py, tw, th) | Just (WidgetTextPlacement txt px py tw th) <- [placement]]
  | Bool
otherwise = Context
-> NodeType
-> Int
-> Float
-> Float
-> Float
-> Float
-> IO [(Text, Float, Float, Float, Float)]
computeWidgetTextPlacements Context
ctx NodeType
nt Int
idx Float
x Float
y Float
w Float
h

-- | Runtime consumer API. The Bool marks the last placement (for table sort
-- arrows); cached labels are translated directly into the consumer.
{-# INLINE forWidgetTextPlacements_ #-}
forWidgetTextPlacements_ ::
  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float ->
  (Bool -> T.Text -> Float -> Float -> Float -> Float -> IO ()) -> IO ()
forWidgetTextPlacements_ :: Context
-> NodeType
-> Int
-> Float
-> Float
-> Float
-> Float
-> (Bool -> Text -> Float -> Float -> Float -> Float -> IO ())
-> IO ()
forWidgetTextPlacements_ Context
ctx NodeType
nt Int
idx Float
x Float
y Float
w Float
h Bool -> Text -> Float -> Float -> Float -> Float -> IO ()
emit
  | NodeType -> Bool
cacheableWidgetLabel NodeType
nt = do
      placement <- Context
-> NodeType
-> Int
-> Float
-> Float
-> IO (Maybe WidgetTextPlacement)
cachedWidgetLabel Context
ctx NodeType
nt Int
idx Float
w Float
h
      case placement of
        Maybe WidgetTextPlacement
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (WidgetTextPlacement Text
txt Float
px Float
py Float
tw Float
th) -> Bool -> Text -> Float -> Float -> Float -> Float -> IO ()
emit Bool
True Text
txt (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
px) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
py) Float
tw Float
th
  | Bool
otherwise = do
      placements <- Context
-> NodeType
-> Int
-> Float
-> Float
-> Float
-> Float
-> IO [(Text, Float, Float, Float, Float)]
computeWidgetTextPlacements Context
ctx NodeType
nt Int
idx Float
x Float
y Float
w Float
h
      let go [] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          go ((Text
txt, Float
px, Float
py, Float
tw, Float
th) : [(Text, Float, Float, Float, Float)]
rest) =
            Bool -> Text -> Float -> Float -> Float -> Float -> IO ()
emit ([(Text, Float, Float, Float, Float)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Float, Float, Float, Float)]
rest) Text
txt Float
px Float
py Float
tw Float
th IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Text, Float, Float, Float, Float)] -> IO ()
go [(Text, Float, Float, Float, Float)]
rest
      go placements

cachedWidgetLabel :: Context -> NodeType -> NodeIdx -> Float -> Float -> IO (Maybe WidgetTextPlacement)
cachedWidgetLabel :: Context
-> NodeType
-> Int
-> Float
-> Float
-> IO (Maybe WidgetTextPlacement)
cachedWidgetLabel Context
ctx NodeType
nt Int
idx Float
w Float
h = do
  fontSizeVal <- NodeArena -> Int -> IO Float
getNodeFontSize (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  si <- getStyleIdx (ctxNodeArena ctx) idx
  txt <- displayText ctx nt idx
  ax <-
    if nt == NodeButton && isTableHeaderStyle si
      then getAlignX (ctxNodeArena ctx) idx
      else pure AlignStart
  let ntTag = NodeType -> Int
forall a. Enum a => a -> Int
fromEnum NodeType
nt
  cache <- readIORef (ctxWidgetTextCache ctx)
  case IM.lookup idx cache of
    Just WidgetTextCacheEntry
e
      | WidgetTextCacheEntry -> Int
wtcNodeType WidgetTextCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ntTag
          Bool -> Bool -> Bool
&& WidgetTextCacheEntry -> Int
wtcStyle WidgetTextCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
si
          Bool -> Bool -> Bool
&& WidgetTextCacheEntry -> Float
wtcFontSize WidgetTextCacheEntry
e Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
fontSizeVal
          Bool -> Bool -> Bool
&& WidgetTextCacheEntry -> Text
wtcText WidgetTextCacheEntry
e Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
txt
          Bool -> Bool -> Bool
&& WidgetTextCacheEntry -> Float
wtcWidth WidgetTextCacheEntry
e Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
w
          Bool -> Bool -> Bool
&& WidgetTextCacheEntry -> Float
wtcHeight WidgetTextCacheEntry
e Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
h
          Bool -> Bool -> Bool
&& WidgetTextCacheEntry -> Int
wtcAlign WidgetTextCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== AlignX -> Int
forall a. Enum a => a -> Int
fromEnum AlignX
ax -> Maybe WidgetTextPlacement -> IO (Maybe WidgetTextPlacement)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WidgetTextCacheEntry -> Maybe WidgetTextPlacement
wtcPlacement WidgetTextCacheEntry
e)
    Maybe WidgetTextCacheEntry
_ -> do
      placement <- Context
-> NodeType
-> Text
-> Int
-> Float
-> AlignX
-> Float
-> Float
-> IO (Maybe WidgetTextPlacement)
computeWidgetLabel Context
ctx NodeType
nt Text
txt Int
si Float
fontSizeVal AlignX
ax Float
w Float
h
      writeIORef
        (ctxWidgetTextCache ctx)
        (IM.insert idx (WidgetTextCacheEntry ntTag si fontSizeVal txt w h (fromEnum ax) placement) cache)
      pure placement

-- All coordinates here are local. centeredTextY snaps the baseline offset,
-- not the origin; final device-pixel snapping stays in the draw backend.
computeWidgetLabel :: Context -> NodeType -> T.Text -> Int -> Float -> AlignX -> Float -> Float -> IO (Maybe WidgetTextPlacement)
computeWidgetLabel :: Context
-> NodeType
-> Text
-> Int
-> Float
-> AlignX
-> Float
-> Float
-> IO (Maybe WidgetTextPlacement)
computeWidgetLabel Context
ctx NodeType
nt Text
txt Int
si Float
fontSizeVal AlignX
ax Float
w Float
h
  | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeButton Bool -> Bool -> Bool
&& Int -> Bool
isCloseButtonStyle Int
si = Maybe WidgetTextPlacement -> IO (Maybe WidgetTextPlacement)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe WidgetTextPlacement
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      (source, _, measure) <- Context
-> NodeType
-> Float
-> Int
-> IO (FontMetrics, Bool, Text -> IO (Float, Float))
resolveFontFor Context
ctx NodeType
nt Float
fontSizeVal Int
si
      fm <- prepareFontMetrics source txt
      (tw, th) <- measure txt
      let (ix, _) = widgetContentInset fm
          (tx, used) = case nt of
            NodeType
NodeButton
              | Int -> Bool
isTableHeaderStyle Int
si -> AlignX
-> Float -> Float -> Float -> FontMetrics -> Text -> (Float, Float)
alignedTextPen AlignX
ax Float
0 Float
w Float
tableCellInset FontMetrics
fm Text
txt
              | Int -> Bool
isMenuItemStyle Int
si ->
                  let inset :: Float
inset = Float
menuItemPadX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ix
                   in (Float
inset, Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
tw (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
inset Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ix)))
              | Bool
otherwise -> AlignX
-> Float -> Float -> Float -> FontMetrics -> Text -> (Float, Float)
alignedTextPen AlignX
AlignCenter Float
0 Float
w Float
0 FontMetrics
fm Text
txt
            NodeType
NodeSelect -> (Float
ix, Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
tw (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ix Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
selectChevronReserve))
            NodeType
NodeTree ->
              let (Int
_, Int
depth, Bool
_, Bool
_) = Int -> (Int, Int, Bool, Bool)
treeDecodeStyle Int
si
               in (FontMetrics -> Int -> Float
treeRowLeading FontMetrics
fm Int
depth, Float
tw)
            NodeType
_ -> (FontMetrics -> Float
checkboxLeading FontMetrics
fm, Float
tw)
      let !placement = Text -> Float -> Float -> Float -> Float -> WidgetTextPlacement
WidgetTextPlacement Text
txt Float
tx (FontMetrics -> Float -> Float -> Float -> Float
centeredTextY FontMetrics
fm Float
0 Float
h Float
th) Float
used Float
th
      pure (Just placement)

-- | Pure geometry of selectable text: the pen origin, centered baseline box and
-- line height. Selectable text never scrolls, so the pen is just the node x.
-- Paint uses this and skips the width measure; span placement adds it.
selectableTextGeometry :: FontMetrics -> Float -> Float -> Float -> (Float, Float, Float)
selectableTextGeometry :: FontMetrics -> Float -> Float -> Float -> (Float, Float, Float)
selectableTextGeometry FontMetrics
fm Float
x Float
y Float
h =
  let lineH :: Float
lineH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
   in (Float
x, FontMetrics -> Float -> Float -> Float -> Float
centeredTextY FontMetrics
fm Float
y Float
h Float
lineH, Float
lineH)

computeWidgetTextPlacements ::
  Context -> NodeType -> NodeIdx -> Float -> Float -> Float -> Float -> IO [(T.Text, Float, Float, Float, Float)]
computeWidgetTextPlacements :: Context
-> NodeType
-> Int
-> Float
-> Float
-> Float
-> Float
-> IO [(Text, Float, Float, Float, Float)]
computeWidgetTextPlacements Context
ctx NodeType
nt Int
idx Float
x Float
y Float
w Float
h = do
  fontSizeVal <- NodeArena -> Int -> IO Float
getNodeFontSize (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  si <- getStyleIdx (ctxNodeArena ctx) idx
  (fm, _, measureTxt) <- resolveFontFor ctx nt fontSizeVal si
  let (ix, iy) = widgetContentInset fm
      lineH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
  case nt of
    NodeType
NodeColorPicker
      | Int -> ColorPickerPart
colorPickerPartOf Int
si ColorPickerPart -> ColorPickerPart -> Bool
forall a. Eq a => a -> a -> Bool
/= ColorPickerPart
PickerPreview -> [(Text, Float, Float, Float, Float)]
-> IO [(Text, Float, Float, Float, Float)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise -> do
          band@(Rect bx _ _ _) <- NodeArena -> Int -> Rect -> IO Rect
colorPickerPartRect (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h)
          let (currentY, _, newY, _) = colorPickerPreviewGeom fm band
              labelH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
          (cw, ch) <- measureTxt colorPickerCurrentLabel
          (nw, nh) <- measureTxt colorPickerNewLabel
          pure
            [ (colorPickerCurrentLabel, bx, centeredTextY fm currentY labelH ch, cw, ch)
            , (colorPickerNewLabel, bx, centeredTextY fm newY labelH nh, nw, nh)
            ]
    NodeType
NodeSlider -> [(Text, Float, Float, Float, Float)]
-> IO [(Text, Float, Float, Float, Float)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    NodeType
NodeTextInput
      | Int -> Bool
textInputSelectableMode Int
si -> do
          value <- Context -> Int -> IO Text
textInputValue Context
ctx Int
idx
          let (penX, ty, selLineH) = selectableTextGeometry fm x y h
          (fw, _) <- measureTxt value
          pure [(value, penX, ty, fw, selLineH)]
      | Bool
otherwise -> do
          let numeric :: Bool
numeric = Int -> Bool
textInputNumericMode Int
si
          ph <- if Bool
numeric then Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"" else NodeArena -> Int -> IO Text
getText (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
          value <- textInputValue ctx idx
          focus <- textInputFocused ctx idx
          let fieldTxt = Text -> Text -> Bool -> Text
textInputFieldText Text
ph Text
value Bool
focus
              Rect _ fieldY _ fieldH = if numeric then Rect x y w h else textInputFieldRect fm x y w h
          (fw, _) <- measureTxt fieldTxt
          scrollX <- syncTextInputScroll ctx idx x y w h
          pure [(fieldTxt, x + ix - scrollX, centeredTextY fm fieldY fieldH lineH, fw, lineH)]
    NodeType
NodeTextArea -> do
      lbl <- NodeArena -> Int -> IO Text
getText (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      value <- textInputValue ctx idx
      (lw, lh) <- measureTxt lbl
      (fw, _) <- measureTxt (if T.null value then " " else value)
      pure
        [ (lbl, x, centeredTextY fm y lineH lh, lw, lh)
        , (value, x + ix, y + iy, fw, h)
        ]
    NodeType
NodeDrawing -> [(Text, Float, Float, Float, Float)]
-> IO [(Text, Float, Float, Float, Float)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    NodeType
_ -> do
      txt <- Context -> NodeType -> Int -> IO Text
displayText Context
ctx NodeType
nt Int
idx
      ax <- getAlignX (ctxNodeArena ctx) idx
      (_, th) <- measureTxt txt
      prepared <- prepareFontMetrics fm txt
      let (tx, used) = alignedTextPen ax x w ix prepared txt
      pure [(txt, tx, centeredTextY fm y h th, used, th)]

-- | Spans inside every floating panel of one kind, clipped to its content box.
collectFloatingSpansInto :: Context -> NodeType -> SpanArena -> IO ()
collectFloatingSpansInto :: Context -> NodeType -> SpanArena -> IO ()
collectFloatingSpansInto Context
ctx NodeType
wanted SpanArena
arena =
  NodeArena -> (Int -> IO ()) -> IO ()
forNodes_ (Context -> NodeArena
ctxNodeArena Context
ctx) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
idx -> do
    nt <- NodeArena -> Int -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
    when (nt == wanted) $ do
      (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
      clip <-
        if isScrollNode nt
          then (\ScrollNode
sn -> ScrollNode -> Float -> Float -> Float -> Float -> Rect
scrollNodeViewport ScrollNode
sn Float
x Float
y Float
w Float
h) <$> readScrollNode (ctxNodeArena ctx) idx
          else padContentClip x y w h <$> getPadding (ctxNodeArena ctx) idx
      walkChildSpans ctx idx clip arena