-- Paint traversal for NanoUI. This module owns the node walk and the
-- structural painters; widget chrome painting lives in sibling
-- NanoUI.Frame.Paint.Widgets.
--
-- The module is shaped for GHC's optimizer: the recursive walker
--
--   paintNodeWithEnv -> lowerNodeVisible (explicit dispatch)
--         -> per-node painters (containers recurse via walkChildrenWithOccluders)
--
-- sits on top of {-# NOINLINE #-} seams, and the heavyweight painters (widget
-- chrome, text, scroll containers, drawings) stay out of line, so no single
-- binding carries the whole painting body inside the recursive loop. That
-- stops the simplifier / SpecConstr from seeing one monolithic binding in the
-- loop, which is what blew up compilation under -fspecialise-aggressively +
-- LLVM; hence the guard flags below.
{-# OPTIONS_GHC -fasm -fno-specialise-aggressively #-}

{-# LANGUAGE DataKinds #-}

module NanoUI.Frame.Paint
  ( lowerShapes
  , walkChildren
  ) where

import Control.Monad (forM_, unless, when)
import Data.Bits ((.&.))
import Data.Maybe (catMaybes, fromMaybe)
import Data.Primitive.PrimArray
  ( PrimArray
  , emptyPrimArray
  , indexPrimArray
  , newPrimArray
  , shrinkMutablePrimArray
  , sizeofPrimArray
  , unsafeFreezePrimArray
  , writePrimArray
  )
import qualified Data.Text as T
import Data.Word (Word32)
import NanoUI.Context
  ( Context (..)
  , CustomDrawingEntry (..)
  , DrawingEntry (..)
  , atlasTextureId
  , cachedCustomDrawingOps
  , cachedDrawingOps
  , getScrollOffset
  , getScrollOffset2D
  , lookupCustomDrawing
  , lookupDrawing
  , lookupImageUv
  , nodeTheme
  , scopeTheme
  )
import NanoUI.Draw
  ( Layer (..)
  , beginLayer
  , currentClip
  , currentLayer
  , emitDrawOps
  , pushImage
  , pushRect
  , pushRoundedStroke
  , pushTextStyled
  , withClip
  )
import NanoUI.Font (ScrollBarSlot (..))
import NanoUI.Frame.Chrome
  ( floatingAncestor
  , imageIdFromText
  , overlayMenuStyle
  , overlayModalStyle
  , overlayWindowStyle
  , paintScrollBarLayout
  , paintStyledRect
  )
import NanoUI.Frame.Node (ScrollNode (..), readScrollNode, resolveFontFor, resolveTextFont, scrollNodeViewport)
import NanoUI.Frame.Paint.Types (PaintEnv (..), buildPaintEnv)
import NanoUI.Frame.Paint.Widgets (paintTextAreaNode, paintTextInputNode, paintWidget)
import NanoUI.Frame.Scroll.Geometry
  ( borderContentClip
  , padContentClip
  , scrollBare
  , scrollBarLayout
  , scrollBarLayouts2D
  , scrollChromeActive
  )
import NanoUI.Frame.Spans (collectNodeTextSpans)
import NanoUI.Id (hashWidgetId)
import NanoUI.Layout.Arena
  ( DirTag (..)
  , NodeIdx
  , NodeType (..)
  , SizingTag (..)
  , arenaCount
  , floatingNodeCount
  , foldNodesM
  , forChildNodes_
  , getHeightSizing
  , getNodeFontColor
  , getNodeFontSize
  , getNodeScope
  , getNodeType
  , getRect
  , getStyleIdx
  , getText
  , getWidgetId
  , getWidthSizing
  , isFloatingNode
  )
import NanoUI.Style
  ( FontStyle (..)
  , FontWeight (..)
  , Style (..)
  , Theme (..)
  , scrollBarThumbColor
  , scrollBarTrackColor
  , themeAccent
  , themeFloatingWindow
  , themeInput
  , themePanel
  , themeSeparator
  , themeWindow
  , fadeAlpha
  , themeDisabledFade
  , themeFocusRing
  )
import NanoUI.Types (Color (..), ImageId (..), Rect (..), V2 (..), colorA, colorRGBA, rectInflate)
import NanoUI.Widgets.ColorPicker (colorPickerPartRect)
import NanoUI.Widgets.Custom (mkCustomDrawContext)
import NanoUI.WidgetText
  ( tableStripeColor
  , textNodeFontStyle
  , textNodeFontWeight
  , textNodeTextDecoration
  )

lowerShapes :: Context -> IO ()
lowerShapes :: Context -> IO ()
lowerShapes Context
ctx = do
  count <- NodeArena -> IO Int
arenaCount (Context -> NodeArena
ctxNodeArena Context
ctx)
  when (count > 0) $ do
    occluders <- collectFloatingOccluders ctx
    buildPaintEnv ctx occluders >>= (`paintNodeWithEnv` 0)

-- | Rects of opaque floating panels, inset past their rounded border, that
-- hide whatever lies fully behind them, as @x0, y0, x1, y1@ runs. Frames
-- without floating nodes skip the arena walk.
collectFloatingOccluders :: Context -> IO (PrimArray Float)
collectFloatingOccluders :: Context -> IO (PrimArray Float)
collectFloatingOccluders Context
ctx = do
  let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  floating <- NodeArena -> IO Int
floatingNodeCount NodeArena
na
  if floating <= 0
    then pure emptyPrimArray
    else do
      buf <- newPrimArray (floating * 4)
      n <- foldNodesM na (addOccluder na buf) 0
      shrinkMutablePrimArray buf (n * 4)
      unsafeFreezePrimArray buf
  where
    isOpaque :: Style -> Bool
isOpaque Style
s = Color -> Word8
colorA (Style -> Color
styleBg Style
s) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
255
    occludes :: Theme -> NodeType -> Bool
occludes Theme
theme = \case
      NodeType
NodeWindow -> Style -> Bool
isOpaque (Theme -> Style
overlayWindowStyle Theme
theme)
      NodeType
NodeModal -> Style -> Bool
isOpaque (Theme -> Style
overlayModalStyle Theme
theme)
      NodeType
NodePopup -> Style -> Bool
isOpaque (Theme -> Style
overlayMenuStyle Theme
theme)
      NodeType
_ -> Bool
False
    addOccluder :: NodeArena
-> MutablePrimArray RealWorld Float -> Int -> Int -> IO Int
addOccluder NodeArena
na MutablePrimArray RealWorld Float
buf !Int
n Int
idx = do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
      opaque <- if isFloatingNode nt then (`occludes` nt) <$> nodeTheme ctx idx else pure False
      if not opaque
        then pure n
        else do
          (x, y, w, h) <- getRect na idx
          if not (w > 6 && h > 6)
            then pure n
            else do
              let !o = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
                  Rect ox oy ow oh = rectInflate (-3) (Rect x y w h)
              writePrimArray buf o ox
              writePrimArray buf (o + 1) oy
              writePrimArray buf (o + 2) (ox + ow)
              writePrimArray buf (o + 3) (oy + oh)
              pure (n + 1)

-- | Clip + occluder short-circuit, then lower the node. NOINLINE so the
-- recursive container walk never exposes the dispatch below to the simplifier.
--
-- The clip test widens the node by 'paintOverhang': a clip frame starts from a
-- blank backdrop, so a node whose focus ring reaches into the clip must repaint
-- even when its own rect stays outside.
{-# NOINLINE paintNodeWithEnv #-}
paintNodeWithEnv :: PaintEnv -> NodeIdx -> IO ()
paintNodeWithEnv :: PaintEnv -> Int -> IO ()
paintNodeWithEnv PaintEnv
env Int
idx = do
  (x, y, w, h) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  Rect cx cy cw ch <- currentClip (peDrawArena env)
  let !l = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
paintOverhang) Float
cx
      !t = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
paintOverhang) Float
cy
      !r = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (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
paintOverhang) (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cw)
      !b = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (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
paintOverhang) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ch)
  unless (w <= 0 || h <= 0 || r <= l || b <= t) $
    unless (occluded (peOccluders env) l t r b) $ do
      nt <- getNodeType (peNodeArena env) idx
      scope <- getNodeScope (peNodeArena env) idx
      if scope == peScope env
        then lowerNodeVisible env idx nt (Rect x y w h)
        else do
          theme <- scopeTheme (peContext env) scope
          lowerNodeVisible env {peTheme = theme, peScope = scope} idx nt (Rect x y w h)

-- | Whether an opaque floating panel fully covers the clipped node rect
-- @l, t, r, b@, which the caller has already checked is non-empty.
{-# INLINE occluded #-}
occluded :: PrimArray Float -> Float -> Float -> Float -> Float -> Bool
occluded :: PrimArray Float -> Float -> Float -> Float -> Float -> Bool
occluded PrimArray Float
occ !Float
l !Float
t !Float
r !Float
b = Int -> Bool
go Int
0
  where
    !end :: Int
end = PrimArray Float -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Float
occ
    go :: Int -> Bool
go !Int
o
      | Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Bool
False
      | Float
l Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
occ Int
o
          Bool -> Bool -> Bool
&& Float
t Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
occ (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          Bool -> Bool -> Bool
&& Float
r Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
occ (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
          Bool -> Bool -> Bool
&& Float
b Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
occ (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) =
          Bool
True
      | Bool
otherwise = Int -> Bool
go (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)

-- | How far a node may paint outside its rect: the focus ring sits 2px out
-- with a 1.5px stroke.
paintOverhang :: Float
paintOverhang :: Float
paintOverhang = Float
4

-- | Explicit per-node-type dispatch. Kept NOINLINE and thin so the recursive
-- loop never sees the branch bodies.
{-# NOINLINE lowerNodeVisible #-}
lowerNodeVisible :: PaintEnv -> NodeIdx -> NodeType -> Rect -> IO ()
lowerNodeVisible :: PaintEnv -> Int -> NodeType -> Rect -> IO ()
lowerNodeVisible PaintEnv
env Int
idx NodeType
nt Rect
rect = do
  case NodeType
nt of
    NodeType
NodeContainer -> PaintEnv -> Int -> Rect -> IO ()
paintContainerNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodePanel -> PaintEnv -> Int -> Rect -> IO ()
paintPanelNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeScrollContainer -> PaintEnv -> Int -> Rect -> IO ()
paintScrollContainerNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeText -> PaintEnv -> Int -> Rect -> IO ()
paintTextNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeSeparator -> PaintEnv -> Rect -> IO ()
paintSeparatorNode PaintEnv
env Rect
rect
    NodeType
NodeTextInput -> PaintEnv -> Int -> Rect -> IO ()
paintTextInputNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeTextArea -> PaintEnv -> Int -> Rect -> IO ()
paintTextAreaNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeSpacer -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    NodeType
NodeModal -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    NodeType
NodeWindow -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    NodeType
NodePopup -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    NodeType
NodeBox -> PaintEnv -> Int -> Rect -> IO ()
paintBoxNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeImage -> PaintEnv -> Int -> Rect -> IO ()
paintImageNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeDrawing -> PaintEnv -> Int -> Rect -> IO ()
paintDrawingNode PaintEnv
env Int
idx Rect
rect
    NodeType
NodeWidget -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    NodeType
_ -> PaintEnv -> Int -> NodeType -> Rect -> IO ()
paintWidget PaintEnv
env Int
idx NodeType
nt Rect
rect
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WidgetId -> Word64
hashWidgetId (PaintEnv -> WidgetId
peFocusRing PaintEnv
env) Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    PaintEnv -> Int -> NodeType -> Rect -> IO ()
paintFocusRing PaintEnv
env Int
idx NodeType
nt Rect
rect

-- | Accent ring around the widget holding keyboard focus. Text fields and
-- selects already swap in an accent border while focused, so they get none.
-- Tree rows fill their scroller edge to edge, so their ring sits just inside
-- the row; colour picker parts ring the square or bar they draw.
{-# NOINLINE paintFocusRing #-}
paintFocusRing :: PaintEnv -> NodeIdx -> NodeType -> Rect -> IO ()
paintFocusRing :: PaintEnv -> Int -> NodeType -> Rect -> IO ()
paintFocusRing PaintEnv
env Int
idx NodeType
nt Rect
rect = do
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  when (wid == peFocusRing env && nt /= NodeTextInput && nt /= NodeTextArea && nt /= NodeSelect) $ do
    target <-
      if nt == NodeColorPicker
        then colorPickerPartRect (peNodeArena env) idx rect
        else pure rect
    let (ring, radius)
          | nt == NodeTree = (rectInflate (-1) target, 0)
          | otherwise = (rectInflate 2 target, 4)
    pushRoundedStroke (peDrawArena env) ring radius 1.5 (themeFocusRing (peTheme env))

paintContainerNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintContainerNode :: PaintEnv -> Int -> Rect -> IO ()
paintContainerNode PaintEnv
env Int
idx Rect
rect = do
  PaintEnv -> Int -> IO ()
walkChildrenWithOccluders PaintEnv
env Int
idx
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  mBuild <- lookupCustomDrawing ctx wid
  forM_ mBuild $ \(CustomDrawingEntry Int
_ CustomDrawBuild
build) -> do
    let fm :: FontMetrics
fm = PaintEnv -> FontMetrics
peFontMetrics PaintEnv
env
        da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
    cdc <- Context -> FontMetrics -> WidgetId -> IO CustomDrawContext
mkCustomDrawContext Context
ctx FontMetrics
fm WidgetId
wid
    withClip da rect (emitDrawOps da fm (resolveTextFont ctx) (build cdc rect))

paintPanelNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintPanelNode :: PaintEnv -> Int -> Rect -> IO ()
paintPanelNode PaintEnv
env Int
idx Rect
rect = do
  let da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
      style :: Style
style = Theme -> Style
themePanel (PaintEnv -> Theme
peTheme PaintEnv
env)
  DrawArena -> Style -> Rect -> IO ()
paintStyledRect DrawArena
da Style
style Rect
rect
  DrawArena -> Rect -> IO () -> IO ()
forall a. DrawArena -> Rect -> IO a -> IO a
withClip DrawArena
da (Style -> Rect -> Rect
borderContentClip Style
style Rect
rect) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PaintEnv -> Int -> IO ()
walkChildrenWithOccluders PaintEnv
env Int
idx

{-# NOINLINE paintScrollContainerNode #-}
paintScrollContainerNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintScrollContainerNode :: PaintEnv -> Int -> Rect -> IO ()
paintScrollContainerNode 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
      arena :: NodeArena
arena = PaintEnv -> NodeArena
peNodeArena PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
      tm :: Theme
tm = PaintEnv -> Theme
peTheme PaintEnv
env
  sn <- NodeArena -> Int -> IO ScrollNode
readScrollNode NodeArena
arena Int
idx
  -- A bare scroller paints nothing at all: it only lends its clip and
  -- offset, so whatever sits behind it (window, panel) keeps showing
  -- through. Grow×grow scrollers (page-level) keep no well so they blend
  -- into the window backdrop. That backdrop only exists while the runner
  -- clears it on DamageFull frames; on clip frames (scrolling, resize)
  -- the strip vacated by scrolled content has no covering command and
  -- the retained texture would show stale pixels, a ghost of a previous
  -- scroll position. Paint the full rect with the window color instead:
  -- invisible on a cleared backdrop, and clip replay then always
  -- repaints the whole viewport.
  unless (scrollBare (snConfig sn)) $ do
    inFloating <- maybe False isFloatingNode <$> floatingAncestor ctx idx
    (wTag, _) <- getWidthSizing arena idx
    (hTag, _) <- getHeightSizing arena idx
    if wTag == SizingGrow && hTag == SizingGrow
      then pushRect da rect (if inFloating then styleBg (themeFloatingWindow tm) else themeWindow tm)
      else do
        let well = (if Bool
inFloating then Theme -> Style
themeFloatingWindow Theme
tm else Theme -> Style
themeInput Theme
tm) {styleCornerRadius = 0}
        paintStyledRect da well rect
  withClip da (scrollNodeViewport sn x y w h) $ walkChildrenWithOccluders env idx
  paintScrollChrome env idx sn rect

-- | Scrollbars of a scroll container whose chrome is active, drawn one layer
-- above the content so they stay on top of it.
paintScrollChrome :: PaintEnv -> NodeIdx -> ScrollNode -> Rect -> IO ()
paintScrollChrome :: PaintEnv -> Int -> ScrollNode -> Rect -> IO ()
paintScrollChrome PaintEnv
env Int
idx (ScrollNode ScrollBarSlot
slot ScrollConfig
cfg Bool
native2D DirTag
dir Padding
pad Float
contentMain Float
contentW) (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
      theme :: Theme
theme = PaintEnv -> Theme
peTheme PaintEnv
env
      Rect Float
_ Float
_ Float
innerW Float
innerH = Float -> Float -> Float -> Float -> Padding -> Rect
padContentClip Float
x Float
y Float
w Float
h Padding
pad
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  bars <-
    if native2D
      then
        if scrollChromeActive cfg DirColumn contentMain innerH || scrollChromeActive cfg DirRow contentW innerW
          then do
            V2 offX offY <- getScrollOffset2D ctx wid
            let (mV, mH) = scrollBarLayouts2D slot cfg x y w h pad contentW contentMain offX offY
            pure (catMaybes [mV, mH])
          else pure []
      else do
        let innerMain = case DirTag
dir of
              DirTag
DirColumn -> Float
innerH
              DirTag
DirRow -> Float
innerW
        if scrollChromeActive cfg dir contentMain innerMain
          then do
            off <- getScrollOffset ctx wid
            pure (catMaybes [scrollBarLayout slot dir x y w h pad contentMain off])
          else pure []
  unless (null bars) $ do
    layer <- currentLayer da
    beginLayer da (if layer == LayerOverlay then LayerChrome else LayerContent)
    let base = case ScrollBarSlot
slot of
          ScrollBarSlot
ScrollBarWindow -> Theme -> Style
themeFloatingWindow Theme
theme
          ScrollBarSlot
_ -> Theme -> Style
themeInput Theme
theme
    mapM_ (paintScrollBarLayout da (scrollBarTrackColor base theme) (scrollBarThumbColor base theme)) bars
    beginLayer da layer

{-# NOINLINE paintTextNode #-}
paintTextNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintTextNode :: PaintEnv -> Int -> Rect -> IO ()
paintTextNode PaintEnv
env Int
idx Rect
rect = do
  let arena :: NodeArena
arena = PaintEnv -> NodeArena
peNodeArena PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
  si <- NodeArena -> Int -> IO Int
getStyleIdx NodeArena
arena Int
idx
  forM_ (tableStripeColor (peTheme env) si) (pushRect da rect)
  raw <- getText arena idx
  unless (T.null raw) $ do
    spans <- collectNodeTextSpans (peContext env) idx
    fontSize <- getNodeFontSize arena idx
    (fm, isNative, _) <- resolveFontFor (peContext env) NodeText fontSize si
    let deco = Int -> TextDecoration
textNodeTextDecoration Int
si
        weight = if Bool
isNative then FontWeight
WeightNormal else Int -> FontWeight
textNodeFontWeight Int
si
        style = if Bool
isNative then FontStyle
FontStyleNormal else Int -> FontStyle
textNodeFontStyle Int
si
    forM_ spans $ \(Rect Float
tx Float
ty Float
_ Float
_, Text
line, Color
spanFg, Color
_) ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
line) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        DrawArena
-> FontMetrics
-> FontWeight
-> FontStyle
-> TextDecoration
-> Float
-> Float
-> Text
-> Color
-> IO ()
pushTextStyled DrawArena
da FontMetrics
fm FontWeight
weight FontStyle
style TextDecoration
deco Float
tx Float
ty Text
line Color
spanFg

paintSeparatorNode :: PaintEnv -> Rect -> IO ()
paintSeparatorNode :: PaintEnv -> Rect -> IO ()
paintSeparatorNode PaintEnv
env (Rect Float
x Float
y Float
w Float
h) =
  DrawArena -> Rect -> Color -> IO ()
pushRect (PaintEnv -> DrawArena
peDrawArena PaintEnv
env) Rect
line (Theme -> Color
themeSeparator (PaintEnv -> Theme
peTheme PaintEnv
env))
  where
    line :: Rect
line
      | Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
h = 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
1) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
w Float
1
      | Bool
otherwise = Float -> Float -> Float -> Float -> Rect
Rect (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
1) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
y Float
1 Float
h

paintBoxNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintBoxNode :: PaintEnv -> Int -> Rect -> IO ()
paintBoxNode PaintEnv
env Int
idx Rect
rect = do
  si <- NodeArena -> Int -> IO Int
getStyleIdx (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  -- styleIdx holds RGBA Word32 bits; see `box` in NanoUI.Widgets.
  pushRect (peDrawArena env) rect (Color (fromIntegral si :: Word32))

paintImageNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintImageNode :: PaintEnv -> Int -> Rect -> IO ()
paintImageNode PaintEnv
env Int
idx Rect
rect = do
  let da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
  tex <- Text -> Int
imageIdFromText (Text -> Int) -> IO Text -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArena -> Int -> IO Text
getText (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  mUv <- lookupImageUv (peContext env) (ImageId tex)
  case mUv of
    Just (Float
u0, Float
v0, Float
u1, Float
v1) -> do
      -- An image may carry a tint in its font colour (an SVG icon). A
      -- disabled image fades the way disabled widget colours do.
      base <- Color -> Maybe Color -> Color
forall a. a -> Maybe a -> a
fromMaybe (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
255 Word8
255 Word8
255) (Maybe Color -> Color) -> IO (Maybe Color) -> IO Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArena -> Int -> IO (Maybe Color)
getNodeFontColor (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
      let tint
            | PaintEnv -> Int
peScope PaintEnv
env Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Color -> Word8 -> Color
fadeAlpha Color
base (Float -> Word8
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word8
colorA Color
base) Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Theme -> Float
themeDisabledFade (PaintEnv -> Theme
peTheme PaintEnv
env))))
            | Bool
otherwise = Color
base
      pushImage da rect atlasTextureId u0 v0 u1 v1 tint
    Maybe (Float, Float, Float, Float)
_ -> DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da Rect
rect (Theme -> Color
themeAccent (PaintEnv -> Theme
peTheme PaintEnv
env))

{-# NOINLINE paintDrawingNode #-}
paintDrawingNode :: PaintEnv -> NodeIdx -> Rect -> IO ()
paintDrawingNode :: PaintEnv -> Int -> Rect -> IO ()
paintDrawingNode PaintEnv
env Int
idx Rect
rect = do
  let ctx :: Context
ctx = PaintEnv -> Context
peContext PaintEnv
env
      fm :: FontMetrics
fm = PaintEnv -> FontMetrics
peFontMetrics PaintEnv
env
      da :: DrawArena
da = PaintEnv -> DrawArena
peDrawArena PaintEnv
env
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx
  mCustomBuild <- lookupCustomDrawing ctx wid
  case mCustomBuild of
    Just (CustomDrawingEntry Int
content CustomDrawBuild
customBuild) -> do
      cdc <- Context -> FontMetrics -> WidgetId -> IO CustomDrawContext
mkCustomDrawContext Context
ctx FontMetrics
fm WidgetId
wid
      ops <- cachedCustomDrawingOps ctx wid content rect cdc customBuild
      withClip da rect (emitDrawOps da fm (resolveTextFont ctx) ops)
    Maybe CustomDrawingEntry
Nothing -> do
      mBuild <- Context -> WidgetId -> IO (Maybe DrawingEntry)
lookupDrawing Context
ctx WidgetId
wid
      forM_ mBuild $ \(DrawingEntry Int
content DrawingBuild
build) -> do
        ops <- Context
-> WidgetId
-> Int
-> Rect
-> DrawingBuild
-> IO (SmallArray DrawOp)
cachedDrawingOps Context
ctx WidgetId
wid Int
content Rect
rect DrawingBuild
build
        withClip da rect (emitDrawOps da fm (resolveTextFont ctx) ops)

-- | Lower the children of @idx@ with the current paint env. NOINLINE keeps
-- this recursive call out of the simplifier's loop analysis, so the whole
-- walker stays a call to opaque seams rather than one inlined monster.
{-# NOINLINE walkChildrenWithOccluders #-}
walkChildrenWithOccluders :: PaintEnv -> NodeIdx -> IO ()
walkChildrenWithOccluders :: PaintEnv -> Int -> IO ()
walkChildrenWithOccluders PaintEnv
env Int
idx =
  NodeArena -> Int -> (Int -> IO ()) -> IO ()
forChildNodes_ (PaintEnv -> NodeArena
peNodeArena PaintEnv
env) Int
idx (PaintEnv -> Int -> IO ()
paintNodeWithEnv PaintEnv
env)

-- | Children walk for callers painting a subtree inside their own clip
-- (floating overlays); builds a fresh env without occluders.
{-# NOINLINE walkChildren #-}
walkChildren :: Context -> NodeIdx -> IO ()
walkChildren :: Context -> Int -> IO ()
walkChildren Context
ctx Int
idx = Context -> PrimArray Float -> IO PaintEnv
buildPaintEnv Context
ctx PrimArray Float
forall a. PrimArray a
emptyPrimArray IO PaintEnv -> (PaintEnv -> 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
>>= (PaintEnv -> Int -> IO ()
`walkChildrenWithOccluders` Int
idx)