{-# LANGUAGE RecordWildCards #-}

-- | The node arena: one frame's layout nodes stored column-wise in primitive
-- arrays (geometry, style, tags and tree links), with accessors, traversals
-- and the layout cache.
module NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (..)
  , NodeArenaArrays (..)
  , isWidgetNode
  , hasCenteredLabel
  , isContainerNode
  , isScrollNode
  , isFloatingNode
  , SizingTag (..)
  , DirTag (..)
  , NodeArena (..)
  , FlexScratch (..)
  , newNodeArena
  , resetNodeArena
  , arenaCount
  , topModalNode
  , floatingNodeCount
  , arenaArrays
  , withArenaArraysSnap
  , geomX
  , geomY
  , geomW
  , geomH
  , styleWVal
  , styleHVal
  , styleMinW
  , styleMinH
  , styleMaxW
  , styleMaxH
  , stylePadL
  , stylePadR
  , stylePadT
  , stylePadB
  , styleGap
  , styleGridMinColW
  , tagNodeType
  , tagDirection
  , tagWSizing
  , tagHSizing
  , tagScrollBarSlot
  , treeParent
  , treeFirstChild
  , treeNextSibling
  , treeStyleIdx
  , treeGridCols
  , readGeom
  , writeGeom
  , readStyle
  , readTagEnum
  , writeTagEnum
  , readTree
  , writeTree
  , addNode
  , addNodeFromLayout
  , rootAttachParent
  , setNodeText
  , getParent
  , getFirstChild
  , getNextSibling
  , getChildCount
  , getNodeType
  , getDirection
  , getGridCols
  , getGridMinColW
  , getScrollContentW
  , setScrollContentW
  , getWidthSizing
  , getHeightSizing
  , getPadding
  , getGap
  , getMinMax
  , parentIsRow
  , getAlignX
  , getAlignY
  , getRect
  , setRect
  , getLayoutRect
  , getClipRect
  , setClipRect
  , snapshotLayoutRects
  , getText
  , getOptions
  , setOptions
  , getWidgetId
  , setWidgetId
  , lookupNodeByWidgetId
  , lookupNodeByKey
  , getStyleIdx
  , setStyleIdx
  , getNodeValue
  , setNodeValue
  , getNodeFontSize
  , getNodeFontColor
  , getNodeScope
  , getArenaScope
  , setArenaScope
  , getScopeSignature
  , ensureScratchCapacity
  , AxisSnapshot (..)
  , ensureAxisSnapshot
  , memoizeWidth
  , forNodes_
  , forChildNodes_
  , foldFlowChildrenM
  , findNodeRevM
  , foldNodeRevM
  , findNodeM
  , foldNodesM
  , findChildM
  , LayoutCache (..)
  , newLayoutCache
  , captureLayoutCache
  , layoutCacheEligible
  , layoutInputsMatch
  , restoreLayoutCache
  ) where

import Control.Exception (bracket_)
import Control.Monad (forM_, when)
import Data.Bits (shiftL, shiftR, xor, (.&.), (.|.))
import Data.HashTable.IO (BasicHashTable)
import qualified Data.HashTable.IO as HT
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Primitive.Array (MutableArray, copyMutableArray, newArray, readArray, sizeofMutableArray, writeArray)
import Data.Primitive.PrimArray
  ( MutablePrimArray
  , copyMutablePrimArray
  , newPrimArray
  , readPrimArray
  , setPrimArray
  , writePrimArray
  , resizeMutablePrimArray
  )
import Data.Primitive.Types (Prim)
import GHC.Exts (RealWorld)
import Data.Text (Text)
import Data.Word (Word8, Word32, Word64)
import qualified Data.Text as T
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Style (AlignX, AlignY, Direction (..), Layout (..), Padding (..), Sizing (..))
import NanoUI.Types (Color (..), Rect (..))

type NodeIdx = Int

data NodeType
  = NodeContainer
  | NodeText
  | NodeSpacer
  | NodeSeparator
  | NodeWidget
  | NodeButton
  | NodeCheckbox
  | NodeSlider
  | NodeTextInput
  | NodeTextArea
  | NodeScrollContainer
  | NodeSelect
  | NodeModal
  | NodeImage
  | NodePanel
  | NodeWindow
  -- Appended last: stored as Word8 in the arena. Update every exhaustive
  -- NodeType case when adding variants.
  | NodeBox
  | NodeRadio
  | NodeColorPicker
  | NodeTree
  | NodePopup
  | NodeDrawing
  deriving (NodeType -> NodeType -> Bool
(NodeType -> NodeType -> Bool)
-> (NodeType -> NodeType -> Bool) -> Eq NodeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeType -> NodeType -> Bool
== :: NodeType -> NodeType -> Bool
$c/= :: NodeType -> NodeType -> Bool
/= :: NodeType -> NodeType -> Bool
Eq, Int -> NodeType -> ShowS
[NodeType] -> ShowS
NodeType -> String
(Int -> NodeType -> ShowS)
-> (NodeType -> String) -> ([NodeType] -> ShowS) -> Show NodeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeType -> ShowS
showsPrec :: Int -> NodeType -> ShowS
$cshow :: NodeType -> String
show :: NodeType -> String
$cshowList :: [NodeType] -> ShowS
showList :: [NodeType] -> ShowS
Show, Int -> NodeType
NodeType -> Int
NodeType -> [NodeType]
NodeType -> NodeType
NodeType -> NodeType -> [NodeType]
NodeType -> NodeType -> NodeType -> [NodeType]
(NodeType -> NodeType)
-> (NodeType -> NodeType)
-> (Int -> NodeType)
-> (NodeType -> Int)
-> (NodeType -> [NodeType])
-> (NodeType -> NodeType -> [NodeType])
-> (NodeType -> NodeType -> [NodeType])
-> (NodeType -> NodeType -> NodeType -> [NodeType])
-> Enum NodeType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: NodeType -> NodeType
succ :: NodeType -> NodeType
$cpred :: NodeType -> NodeType
pred :: NodeType -> NodeType
$ctoEnum :: Int -> NodeType
toEnum :: Int -> NodeType
$cfromEnum :: NodeType -> Int
fromEnum :: NodeType -> Int
$cenumFrom :: NodeType -> [NodeType]
enumFrom :: NodeType -> [NodeType]
$cenumFromThen :: NodeType -> NodeType -> [NodeType]
enumFromThen :: NodeType -> NodeType -> [NodeType]
$cenumFromTo :: NodeType -> NodeType -> [NodeType]
enumFromTo :: NodeType -> NodeType -> [NodeType]
$cenumFromThenTo :: NodeType -> NodeType -> NodeType -> [NodeType]
enumFromThenTo :: NodeType -> NodeType -> NodeType -> [NodeType]
Enum, NodeType
NodeType -> NodeType -> Bounded NodeType
forall a. a -> a -> Bounded a
$cminBound :: NodeType
minBound :: NodeType
$cmaxBound :: NodeType
maxBound :: NodeType
Bounded)

isWidgetNode :: NodeType -> Bool
isWidgetNode :: NodeType -> Bool
isWidgetNode NodeType
nt =
  case NodeType
nt of
    NodeType
NodeWidget -> Bool
True
    NodeType
NodeButton -> Bool
True
    NodeType
NodeCheckbox -> Bool
True
    NodeType
NodeRadio -> Bool
True
    NodeType
NodeSlider -> Bool
True
    NodeType
NodeTextInput -> Bool
True
    NodeType
NodeTextArea -> Bool
True
    NodeType
NodeSelect -> Bool
True
    NodeType
NodeColorPicker -> Bool
True
    NodeType
NodeTree -> Bool
True
    NodeType
NodeDrawing -> Bool
True
    NodeType
_ -> Bool
False

-- | Widgets that paint one line of label text vertically centered in their box
-- ('computeWidgetLabel'), which is also their baseline.
hasCenteredLabel :: NodeType -> Bool
hasCenteredLabel :: NodeType -> Bool
hasCenteredLabel NodeType
nt =
  case NodeType
nt of
    NodeType
NodeButton -> Bool
True
    NodeType
NodeSelect -> Bool
True
    NodeType
NodeTree -> Bool
True
    NodeType
NodeCheckbox -> Bool
True
    NodeType
NodeRadio -> Bool
True
    NodeType
_ -> Bool
False

isContainerNode :: NodeType -> Bool
isContainerNode :: NodeType -> Bool
isContainerNode NodeType
nt =
  case NodeType
nt of
    NodeType
NodeContainer -> Bool
True
    NodeType
NodeScrollContainer -> Bool
True
    NodeType
NodeModal -> Bool
True
    NodeType
NodePanel -> Bool
True
    NodeType
NodeWindow -> Bool
True
    NodeType
NodePopup -> Bool
True
    NodeType
_ -> Bool
False

isScrollNode :: NodeType -> Bool
isScrollNode :: NodeType -> Bool
isScrollNode NodeType
nt = NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeScrollContainer

isFloatingNode :: NodeType -> Bool
isFloatingNode :: NodeType -> Bool
isFloatingNode NodeType
nt = NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeModal Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeWindow Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodePopup

data SizingTag
  = SizingFixed
  | SizingFit
  | SizingGrow
  | SizingShrink
  | SizingPercent
  deriving (SizingTag -> SizingTag -> Bool
(SizingTag -> SizingTag -> Bool)
-> (SizingTag -> SizingTag -> Bool) -> Eq SizingTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SizingTag -> SizingTag -> Bool
== :: SizingTag -> SizingTag -> Bool
$c/= :: SizingTag -> SizingTag -> Bool
/= :: SizingTag -> SizingTag -> Bool
Eq, Int -> SizingTag -> ShowS
[SizingTag] -> ShowS
SizingTag -> String
(Int -> SizingTag -> ShowS)
-> (SizingTag -> String)
-> ([SizingTag] -> ShowS)
-> Show SizingTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SizingTag -> ShowS
showsPrec :: Int -> SizingTag -> ShowS
$cshow :: SizingTag -> String
show :: SizingTag -> String
$cshowList :: [SizingTag] -> ShowS
showList :: [SizingTag] -> ShowS
Show, Int -> SizingTag
SizingTag -> Int
SizingTag -> [SizingTag]
SizingTag -> SizingTag
SizingTag -> SizingTag -> [SizingTag]
SizingTag -> SizingTag -> SizingTag -> [SizingTag]
(SizingTag -> SizingTag)
-> (SizingTag -> SizingTag)
-> (Int -> SizingTag)
-> (SizingTag -> Int)
-> (SizingTag -> [SizingTag])
-> (SizingTag -> SizingTag -> [SizingTag])
-> (SizingTag -> SizingTag -> [SizingTag])
-> (SizingTag -> SizingTag -> SizingTag -> [SizingTag])
-> Enum SizingTag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SizingTag -> SizingTag
succ :: SizingTag -> SizingTag
$cpred :: SizingTag -> SizingTag
pred :: SizingTag -> SizingTag
$ctoEnum :: Int -> SizingTag
toEnum :: Int -> SizingTag
$cfromEnum :: SizingTag -> Int
fromEnum :: SizingTag -> Int
$cenumFrom :: SizingTag -> [SizingTag]
enumFrom :: SizingTag -> [SizingTag]
$cenumFromThen :: SizingTag -> SizingTag -> [SizingTag]
enumFromThen :: SizingTag -> SizingTag -> [SizingTag]
$cenumFromTo :: SizingTag -> SizingTag -> [SizingTag]
enumFromTo :: SizingTag -> SizingTag -> [SizingTag]
$cenumFromThenTo :: SizingTag -> SizingTag -> SizingTag -> [SizingTag]
enumFromThenTo :: SizingTag -> SizingTag -> SizingTag -> [SizingTag]
Enum, SizingTag
SizingTag -> SizingTag -> Bounded SizingTag
forall a. a -> a -> Bounded a
$cminBound :: SizingTag
minBound :: SizingTag
$cmaxBound :: SizingTag
maxBound :: SizingTag
Bounded)

data DirTag = DirRow | DirColumn
  deriving (DirTag -> DirTag -> Bool
(DirTag -> DirTag -> Bool)
-> (DirTag -> DirTag -> Bool) -> Eq DirTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DirTag -> DirTag -> Bool
== :: DirTag -> DirTag -> Bool
$c/= :: DirTag -> DirTag -> Bool
/= :: DirTag -> DirTag -> Bool
Eq, Int -> DirTag -> ShowS
[DirTag] -> ShowS
DirTag -> String
(Int -> DirTag -> ShowS)
-> (DirTag -> String) -> ([DirTag] -> ShowS) -> Show DirTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DirTag -> ShowS
showsPrec :: Int -> DirTag -> ShowS
$cshow :: DirTag -> String
show :: DirTag -> String
$cshowList :: [DirTag] -> ShowS
showList :: [DirTag] -> ShowS
Show, Int -> DirTag
DirTag -> Int
DirTag -> [DirTag]
DirTag -> DirTag
DirTag -> DirTag -> [DirTag]
DirTag -> DirTag -> DirTag -> [DirTag]
(DirTag -> DirTag)
-> (DirTag -> DirTag)
-> (Int -> DirTag)
-> (DirTag -> Int)
-> (DirTag -> [DirTag])
-> (DirTag -> DirTag -> [DirTag])
-> (DirTag -> DirTag -> [DirTag])
-> (DirTag -> DirTag -> DirTag -> [DirTag])
-> Enum DirTag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: DirTag -> DirTag
succ :: DirTag -> DirTag
$cpred :: DirTag -> DirTag
pred :: DirTag -> DirTag
$ctoEnum :: Int -> DirTag
toEnum :: Int -> DirTag
$cfromEnum :: DirTag -> Int
fromEnum :: DirTag -> Int
$cenumFrom :: DirTag -> [DirTag]
enumFrom :: DirTag -> [DirTag]
$cenumFromThen :: DirTag -> DirTag -> [DirTag]
enumFromThen :: DirTag -> DirTag -> [DirTag]
$cenumFromTo :: DirTag -> DirTag -> [DirTag]
enumFromTo :: DirTag -> DirTag -> [DirTag]
$cenumFromThenTo :: DirTag -> DirTag -> DirTag -> [DirTag]
enumFromThenTo :: DirTag -> DirTag -> DirTag -> [DirTag]
Enum, DirTag
DirTag -> DirTag -> Bounded DirTag
forall a. a -> a -> Bounded a
$cminBound :: DirTag
minBound :: DirTag
$cmaxBound :: DirTag
maxBound :: DirTag
Bounded)

-- | Node columns. Each array holds one row of @*Stride@ slots per node; the
-- column constants below name the slots.
data NodeArenaArrays = NodeArenaArrays
  { NodeArenaArrays -> MutablePrimArray RealWorld Float
naArrGeom :: !(MutablePrimArray RealWorld Float)
  , NodeArenaArrays -> MutablePrimArray RealWorld Float
naArrStyle :: !(MutablePrimArray RealWorld Float)
  , NodeArenaArrays -> MutablePrimArray RealWorld Word8
naArrTags :: !(MutablePrimArray RealWorld Word8)
  , NodeArenaArrays -> MutablePrimArray RealWorld Int
naArrTree :: !(MutablePrimArray RealWorld Int)
  , NodeArenaArrays -> MutableArray RealWorld Text
naArrTextStore :: !(MutableArray RealWorld Text)
  , NodeArenaArrays -> MutableArray RealWorld [Text]
naArrOptionsStore :: !(MutableArray RealWorld [Text])
  , NodeArenaArrays -> MutablePrimArray RealWorld Int
naArrFontColor :: !(MutablePrimArray RealWorld Int)
  , NodeArenaArrays -> MutablePrimArray RealWorld Int
naArrScope :: !(MutablePrimArray RealWorld Int)
  -- ^ The paint scope each node was added under: a theme index shifted left
  -- one bit, and the disabled flag in bit 0. See
  -- 'NanoUI.Context.Types.ThemeScopes'.
  }

data NodeArena = NodeArena
  { NodeArena -> IORef Int
naCount :: IORef Int
  , NodeArena -> IORef Int
naCapacity :: IORef Int
  , NodeArena -> IORef NodeArenaArrays
naArrays :: IORef NodeArenaArrays
  , NodeArena -> IORef (Maybe NodeArenaArrays)
naArraysSnap :: IORef (Maybe NodeArenaArrays)
  , NodeArena -> IORef FlexScratch
naScratch :: IORef FlexScratch
  -- Per-depth copies of the axis scratch while the position pass recurses.
  -- Children reuse the working scratch, so a container's child list must be
  -- snapshotted at its own depth to survive recursive positioning.
  , NodeArena -> IORef Int
naSnapCap :: IORef Int
  , NodeArena -> IORef (MutableArray RealWorld (Maybe AxisSnapshot))
naSnapLevels :: IORef (MutableArray RealWorld (Maybe AxisSnapshot))
  -- Per-frame memos keyed by (node, quantized width): wrapped text sizes and
  -- fit heights. Text and style are fixed per node within a frame, so the
  -- frame tag is all that is needed to invalidate across frames.
  , NodeArena -> IORef Word32
naFrameTag :: IORef Word32
  , NodeArena -> IORef WidthMemo
naWrapMemo :: IORef WidthMemo
  , NodeArena -> IORef WidthMemo
naFitMemo :: IORef WidthMemo
  , NodeArena -> IORef Word32
naEpoch :: IORef Word32
  , NodeArena -> IORef (BasicHashTable WidgetId Word64)
naIndex :: IORef (BasicHashTable WidgetId Word64)
  -- The scope new nodes are stamped with, and a signature of the scoped
  -- nodes added this frame, so a frame that only changes scopes can tell.
  , NodeArena -> IORef Int
naScope :: IORef Int
  , NodeArena -> IORef Word64
naScopeSig :: IORef Word64
  , NodeArena -> IORef Int
naTopModal :: IORef Int
  -- ^ Index of the last modal node added this frame, or -1. Node types are
  -- fixed when a node is added and indices only grow until a reset, so this
  -- is the topmost modal without a scan.
  , NodeArena -> IORef Int
naFloatingCount :: IORef Int
  -- ^ Floating nodes (windows, modals, popups) added this frame.
  }

-- | Flex solver scratch: child node indices, their measured widths and
-- heights, and the distributed output sizes.
data FlexScratch = FlexScratch
  { FlexScratch -> Int
fsCap :: !Int
  , FlexScratch -> MutablePrimArray RealWorld Int
fsIdx :: !(MutablePrimArray RealWorld Int)
  , FlexScratch -> MutablePrimArray RealWorld Float
fsW :: !(MutablePrimArray RealWorld Float)
  , FlexScratch -> MutablePrimArray RealWorld Float
fsH :: !(MutablePrimArray RealWorld Float)
  , FlexScratch -> MutablePrimArray RealWorld Float
fsOutW :: !(MutablePrimArray RealWorld Float)
  , FlexScratch -> MutablePrimArray RealWorld Float
fsOutH :: !(MutablePrimArray RealWorld Float)
  }

-- | A per-frame memo of two floats per node keyed by a width. Slots hold
-- @(key, a, b)@ per node; an entry is live only while its tag equals the
-- arena's frame tag.
data WidthMemo = WidthMemo
  { WidthMemo -> MutablePrimArray RealWorld Word32
wmTags :: !(MutablePrimArray RealWorld Word32)
  , WidthMemo -> MutablePrimArray RealWorld Float
wmSlots :: !(MutablePrimArray RealWorld Float)
  }

-- | Initial number of per-depth layout snapshot levels. The level array grows
-- on demand (see 'ensureSnapLevelsArr'), so this is not a depth limit.
maxSnapDepth :: Int
maxSnapDepth :: Int
maxSnapDepth = Int
256

-- | One depth level's frozen child indices and distributed main-axis sizes.
data AxisSnapshot = AxisSnapshot
  { AxisSnapshot -> MutablePrimArray RealWorld Int
asIdx :: !(MutablePrimArray RealWorld Int)
  , AxisSnapshot -> MutablePrimArray RealWorld Float
asOut :: !(MutablePrimArray RealWorld Float)
  }

initialCapacity :: Int
initialCapacity :: Int
initialCapacity = Int
256

-- | Geometry columns: solved rect, the position snapshot taken by
-- 'snapshotLayoutRects', and the clip rect.
geomStride, geomX, geomY, geomW, geomH, geomLayoutX, geomLayoutY :: Int
geomStride :: Int
geomStride = Int
10
geomX :: Int
geomX = Int
0
geomY :: Int
geomY = Int
1
geomW :: Int
geomW = Int
2
geomH :: Int
geomH = Int
3
geomLayoutX :: Int
geomLayoutX = Int
4
geomLayoutY :: Int
geomLayoutY = Int
5

geomClipX, geomClipY, geomClipW, geomClipH :: Int
geomClipX :: Int
geomClipX = Int
6
geomClipY :: Int
geomClipY = Int
7
geomClipW :: Int
geomClipW = Int
8
geomClipH :: Int
geomClipH = Int
9

-- | Style columns: sizing values, padding, gap, min/max, grow, and per-node
-- values that are not layout inputs (scroll extent, node value, font size).
styleStride, styleWVal, styleHVal, stylePadL, stylePadR, stylePadT, stylePadB :: Int
styleStride :: Int
styleStride = Int
16
styleWVal :: Int
styleWVal = Int
0
styleHVal :: Int
styleHVal = Int
1
stylePadL :: Int
stylePadL = Int
2
stylePadR :: Int
stylePadR = Int
3
stylePadT :: Int
stylePadT = Int
4
stylePadB :: Int
stylePadB = Int
5

styleGap, styleMinW, styleMinH, styleMaxW, styleMaxH, styleGrow :: Int
styleGap :: Int
styleGap = Int
6
styleMinW :: Int
styleMinW = Int
7
styleMinH :: Int
styleMinH = Int
8
styleMaxW :: Int
styleMaxW = Int
9
styleMaxH :: Int
styleMaxH = Int
10
styleGrow :: Int
styleGrow = Int
11

styleScrollContentW, styleNodeValue, styleGridMinColW, styleFontSize :: Int
styleScrollContentW :: Int
styleScrollContentW = Int
12
styleNodeValue :: Int
styleNodeValue = Int
13
styleGridMinColW :: Int
styleGridMinColW = Int
14
styleFontSize :: Int
styleFontSize = Int
15

-- | Tag columns (enum values as 'Word8'). Column 7 is unused. The scrollbar
-- slot is a solver output: measurement writes it for scroll containers, so
-- the layout cache skips it when comparing inputs and restores it on a hit.
tagStride, tagNodeType, tagDirection, tagWSizing, tagHSizing, tagScrollBarSlot, tagAlignX, tagAlignY :: Int
tagStride :: Int
tagStride = Int
8 -- a power of two: layoutInputsMatch masks by it
tagNodeType :: Int
tagNodeType = Int
0
tagDirection :: Int
tagDirection = Int
1
tagWSizing :: Int
tagWSizing = Int
2
tagHSizing :: Int
tagHSizing = Int
3
tagScrollBarSlot :: Int
tagScrollBarSlot = Int
4
tagAlignX :: Int
tagAlignX = Int
5
tagAlignY :: Int
tagAlignY = Int
6

-- | Tree columns: links, widget id, style index, text index (-1 for no text),
-- and the grid column count (containers only).
treeStride, treeParent, treeFirstChild, treeNextSibling, treeChildCount :: Int
treeStride :: Int
treeStride = Int
8
treeParent :: Int
treeParent = Int
0
treeFirstChild :: Int
treeFirstChild = Int
1
treeNextSibling :: Int
treeNextSibling = Int
2
treeChildCount :: Int
treeChildCount = Int
3

treeWidgetId, treeStyleIdx, treeTextIdx, treeGridCols :: Int
treeWidgetId :: Int
treeWidgetId = Int
4
treeStyleIdx :: Int
treeStyleIdx = Int
5
treeTextIdx :: Int
treeTextIdx = Int
6
treeGridCols :: Int
treeGridCols = Int
7

{-# INLINE readGeom #-}
readGeom :: NodeArenaArrays -> NodeIdx -> Int -> IO Float
readGeom :: NodeArenaArrays -> Int -> Int -> IO Float
readGeom NodeArenaArrays
a Int
idx Int
col = MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Float
naArrGeom NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
geomStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)

{-# INLINE writeGeom #-}
writeGeom :: NodeArenaArrays -> NodeIdx -> Int -> Float -> IO ()
writeGeom :: NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeGeom NodeArenaArrays
a Int
idx Int
col = MutablePrimArray (PrimState IO) Float -> Int -> Float -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Float
naArrGeom NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
geomStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)

{-# INLINE readStyle #-}
readStyle :: NodeArenaArrays -> NodeIdx -> Int -> IO Float
readStyle :: NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
col = MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Float
naArrStyle NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
styleStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)

{-# INLINE writeStyle #-}
writeStyle :: NodeArenaArrays -> NodeIdx -> Int -> Float -> IO ()
writeStyle :: NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeStyle NodeArenaArrays
a Int
idx Int
col = MutablePrimArray (PrimState IO) Float -> Int -> Float -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Float
naArrStyle NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
styleStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)

{-# INLINE readTagEnum #-}
readTagEnum :: Enum e => NodeArenaArrays -> NodeIdx -> Int -> IO e
readTagEnum :: forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
col = do
  t <- MutablePrimArray (PrimState IO) Word8 -> Int -> IO Word8
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Word8
naArrTags NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tagStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)
  pure $! toEnum (fromIntegral t)

{-# INLINE writeTagEnum #-}
writeTagEnum :: Enum e => NodeArenaArrays -> NodeIdx -> Int -> e -> IO ()
writeTagEnum :: forall e. Enum e => NodeArenaArrays -> Int -> Int -> e -> IO ()
writeTagEnum NodeArenaArrays
a Int
idx Int
col e
v = MutablePrimArray (PrimState IO) Word8 -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Word8
naArrTags NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tagStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (e -> Int
forall a. Enum a => a -> Int
fromEnum e
v))

{-# INLINE readTree #-}
readTree :: NodeArenaArrays -> NodeIdx -> Int -> IO Int
readTree :: NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
col = MutablePrimArray (PrimState IO) Int -> Int -> IO Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Int
naArrTree NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
treeStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)

{-# INLINE writeTree #-}
writeTree :: NodeArenaArrays -> NodeIdx -> Int -> Int -> IO ()
writeTree :: NodeArenaArrays -> Int -> Int -> Int -> IO ()
writeTree NodeArenaArrays
a Int
idx Int
col = MutablePrimArray (PrimState IO) Int -> Int -> Int -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Int
naArrTree NodeArenaArrays
a) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
treeStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)

newNodeArenaArrays :: Int -> IO NodeArenaArrays
newNodeArenaArrays :: Int -> IO NodeArenaArrays
newNodeArenaArrays Int
cap = do
  naArrGeom <- Int -> IO (MutablePrimArray (PrimState IO) Float)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
geomStride)
  naArrStyle <- newPrimArray (cap * styleStride)
  naArrTags <- newPrimArray (cap * tagStride)
  naArrTree <- newPrimArray (cap * treeStride)
  naArrTextStore <- newArray cap T.empty
  naArrOptionsStore <- newArray cap []
  naArrFontColor <- newPrimArray cap
  naArrScope <- newPrimArray cap
  pure NodeArenaArrays {..}

newFlexScratch :: Int -> IO FlexScratch
newFlexScratch :: Int -> IO FlexScratch
newFlexScratch Int
fsCap = do
  fsIdx <- Int -> IO (MutablePrimArray (PrimState IO) Int)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
fsCap
  fsW <- newPrimArray fsCap
  fsH <- newPrimArray fsCap
  fsOutW <- newPrimArray fsCap
  fsOutH <- newPrimArray fsCap
  pure FlexScratch {..}

-- | Memo slots per node: key and two values.
memoStride :: Int
memoStride :: Int
memoStride = Int
3

-- Tags start zeroed: frame tags are never 0, so fresh entries always miss.
newWidthMemo :: Int -> IO WidthMemo
newWidthMemo :: Int -> IO WidthMemo
newWidthMemo Int
cap = do
  wmTags <- Int -> IO (MutablePrimArray (PrimState IO) Word32)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
cap
  setPrimArray wmTags 0 cap 0
  wmSlots <- newPrimArray (cap * memoStride)
  pure WidthMemo {..}

newNodeArena :: IO NodeArena
newNodeArena :: IO NodeArena
newNodeArena = do
  let cap :: Int
cap = Int
initialCapacity
      scratchCap :: Int
scratchCap = Int
64
  naCount <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  naCapacity <- newIORef cap
  naArrays <- newIORef =<< newNodeArenaArrays cap
  naArraysSnap <- newIORef Nothing
  naScratch <- newIORef =<< newFlexScratch scratchCap
  naSnapCap <- newIORef scratchCap
  naSnapLevels <- newIORef =<< newArray maxSnapDepth Nothing
  naFrameTag <- newIORef 1
  naWrapMemo <- newIORef =<< newWidthMemo cap
  naFitMemo <- newIORef =<< newWidthMemo cap
  naEpoch <- newIORef 1
  naIndex <- newIORef =<< HT.new
  naScope <- newIORef 0
  naScopeSig <- newIORef 0
  naTopModal <- newIORef (-1)
  naFloatingCount <- newIORef 0
  pure NodeArena {..}

resetNodeArena :: NodeArena -> IO ()
resetNodeArena :: NodeArena -> IO ()
resetNodeArena NodeArena
na = do
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef Int
naCount NodeArena
na) Int
0
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef Int
naScope NodeArena
na) Int
0
  IORef Word64 -> Word64 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef Word64
naScopeSig NodeArena
na) Word64
0
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef Int
naTopModal NodeArena
na) (-Int
1)
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef Int
naFloatingCount NodeArena
na) Int
0
  !ft <- IORef Word32 -> IO Word32
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Word32
naFrameTag NodeArena
na)
  writeIORef (naFrameTag na) (if ft == maxBound then 1 else ft + 1)
  !ep <- readIORef (naEpoch na)
  let !ep' = Word32
ep Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1
  if ep' == 0 || (ep' .&. 0x7F == 0)
    then do
      let !nextEp = if Word32
ep' Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then Word32
1 else Word32
ep'
      writeIORef (naEpoch na) nextEp
      writeIORef (naIndex na) =<< HT.new
    else writeIORef (naEpoch na) ep'

-- | The topmost (last added) modal node, if any.
{-# INLINE topModalNode #-}
topModalNode :: NodeArena -> IO (Maybe NodeIdx)
topModalNode :: NodeArena -> IO (Maybe Int)
topModalNode NodeArena
na = do
  i <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Int
naTopModal NodeArena
na)
  pure (if i >= 0 then Just i else Nothing)

{-# INLINE floatingNodeCount #-}
floatingNodeCount :: NodeArena -> IO Int
floatingNodeCount :: NodeArena -> IO Int
floatingNodeCount NodeArena
na = IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Int
naFloatingCount NodeArena
na)

{-# INLINE arenaCount #-}
arenaCount :: NodeArena -> IO Int
arenaCount :: NodeArena -> IO Int
arenaCount NodeArena
na = IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Int
naCount NodeArena
na)

{-# INLINE arenaArrays #-}
arenaArrays :: NodeArena -> IO NodeArenaArrays
arenaArrays :: NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na = do
  m <- IORef (Maybe NodeArenaArrays) -> IO (Maybe NodeArenaArrays)
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef (Maybe NodeArenaArrays)
naArraysSnap NodeArena
na)
  case m of
    Just NodeArenaArrays
a -> NodeArenaArrays -> IO NodeArenaArrays
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeArenaArrays
a
    Maybe NodeArenaArrays
Nothing -> IORef NodeArenaArrays -> IO NodeArenaArrays
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef NodeArenaArrays
naArrays NodeArena
na)

-- | Pin arena column arrays for a layout pass so field reads skip naArrays IORef.
withArenaArraysSnap :: NodeArena -> IO a -> IO a
withArenaArraysSnap :: forall a. NodeArena -> IO a -> IO a
withArenaArraysSnap NodeArena
na IO a
act =
  IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
    (IORef NodeArenaArrays -> IO NodeArenaArrays
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef NodeArenaArrays
naArrays NodeArena
na) IO NodeArenaArrays -> (NodeArenaArrays -> 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
>>= IORef (Maybe NodeArenaArrays) -> Maybe NodeArenaArrays -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef (Maybe NodeArenaArrays)
naArraysSnap NodeArena
na) (Maybe NodeArenaArrays -> IO ())
-> (NodeArenaArrays -> Maybe NodeArenaArrays)
-> NodeArenaArrays
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeArenaArrays -> Maybe NodeArenaArrays
forall a. a -> Maybe a
Just)
    (IORef (Maybe NodeArenaArrays) -> Maybe NodeArenaArrays -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef (Maybe NodeArenaArrays)
naArraysSnap NodeArena
na) Maybe NodeArenaArrays
forall a. Maybe a
Nothing)
    IO a
act

{-# NOINLINE ensureCapacity #-}
ensureCapacity :: NodeArena -> Int -> IO ()
ensureCapacity :: NodeArena -> Int -> IO ()
ensureCapacity NodeArena
na Int
needed = do
  cap <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Int
naCapacity NodeArena
na)
  if needed < cap
    then pure ()
    else do
      let newCap = Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
      newA <- readIORef (naArrays na) >>= growNodeArenaArrays cap newCap
      growWidthMemo (naWrapMemo na) cap newCap
      growWidthMemo (naFitMemo na) cap newCap
      writeIORef (naArrays na) newA
      m <- readIORef (naArraysSnap na)
      case m of
        Just{} -> IORef (Maybe NodeArenaArrays) -> Maybe NodeArenaArrays -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef (Maybe NodeArenaArrays)
naArraysSnap NodeArena
na) (NodeArenaArrays -> Maybe NodeArenaArrays
forall a. a -> Maybe a
Just NodeArenaArrays
newA)
        Maybe NodeArenaArrays
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      writeIORef (naCapacity na) newCap

-- | Copy of @a@ with room for @newCap@ nodes; new slots are zero or empty.
growNodeArenaArrays :: Int -> Int -> NodeArenaArrays -> IO NodeArenaArrays
growNodeArenaArrays :: Int -> Int -> NodeArenaArrays -> IO NodeArenaArrays
growNodeArenaArrays Int
cap Int
newCap NodeArenaArrays
a = do
  naArrGeom <- MutablePrimArray RealWorld Float
-> Int -> Int -> Float -> IO (MutablePrimArray RealWorld Float)
forall a.
Prim a =>
MutablePrimArray RealWorld a
-> Int -> Int -> a -> IO (MutablePrimArray RealWorld a)
growPrimArrayCopy (NodeArenaArrays -> MutablePrimArray RealWorld Float
naArrGeom NodeArenaArrays
a) (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
geomStride) (Int
newCap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
geomStride) Float
0
  naArrStyle <- growPrimArrayCopy (naArrStyle a) (cap * styleStride) (newCap * styleStride) 0
  naArrTags <- growPrimArrayCopy (naArrTags a) (cap * tagStride) (newCap * tagStride) 0
  naArrTree <- growPrimArrayCopy (naArrTree a) (cap * treeStride) (newCap * treeStride) 0
  naArrTextStore <- growBoxedStoreCopy T.empty (naArrTextStore a) cap newCap
  naArrOptionsStore <- growBoxedStoreCopy [] (naArrOptionsStore a) cap newCap
  naArrFontColor <- growPrimArrayCopy (naArrFontColor a) cap newCap 0
  naArrScope <- growPrimArrayCopy (naArrScope a) cap newCap 0
  pure NodeArenaArrays {..}

{-# NOINLINE growPrimArrayCopy #-}
growPrimArrayCopy :: Prim a => MutablePrimArray RealWorld a -> Int -> Int -> a -> IO (MutablePrimArray RealWorld a)
growPrimArrayCopy :: forall a.
Prim a =>
MutablePrimArray RealWorld a
-> Int -> Int -> a -> IO (MutablePrimArray RealWorld a)
growPrimArrayCopy MutablePrimArray RealWorld a
oldArr Int
cap Int
newCap a
defVal = do
  newArr <- MutablePrimArray (PrimState IO) a
-> Int -> IO (MutablePrimArray (PrimState IO) a)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> m (MutablePrimArray (PrimState m) a)
resizeMutablePrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
oldArr Int
newCap
  setPrimArray newArr cap (newCap - cap) defVal
  pure newArr

growWidthMemo :: IORef WidthMemo -> Int -> Int -> IO ()
growWidthMemo :: IORef WidthMemo -> Int -> Int -> IO ()
growWidthMemo IORef WidthMemo
ref Int
cap Int
newCap = do
  WidthMemo tags slots <- IORef WidthMemo -> IO WidthMemo
forall a. IORef a -> IO a
readIORef IORef WidthMemo
ref
  wmTags <- growPrimArrayCopy tags cap newCap 0
  wmSlots <- growPrimArrayCopy slots (cap * memoStride) (newCap * memoStride) 0
  writeIORef ref WidthMemo {..}

{-# NOINLINE growBoxedStoreCopy #-}
growBoxedStoreCopy :: a -> MutableArray RealWorld a -> Int -> Int -> IO (MutableArray RealWorld a)
growBoxedStoreCopy :: forall a.
a
-> MutableArray RealWorld a
-> Int
-> Int
-> IO (MutableArray RealWorld a)
growBoxedStoreCopy a
emptyVal MutableArray RealWorld a
arr Int
oldCap Int
newCap = do
  newArr <- Int -> a -> IO (MutableArray (PrimState IO) a)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
newCap a
emptyVal
  copyMutableArray newArr 0 arr 0 oldCap
  pure newArr

{-# INLINE sizingTag #-}
sizingTag :: Sizing -> (SizingTag, Float)
sizingTag :: Sizing -> (SizingTag, Float)
sizingTag (Fixed Float
v) = (SizingTag
SizingFixed, Float
v)
sizingTag Sizing
Fit = (SizingTag
SizingFit, Float
0)
sizingTag (Grow Float
g) = (SizingTag
SizingGrow, Float
g)
sizingTag (Shrink Float
s) = (SizingTag
SizingShrink, Float
s)
sizingTag (Percent Float
p) = (SizingTag
SizingPercent, Float
p)

-- Empty stack attaches to node 0 so walks from the page root still reach
-- windows/modals/popups built as UI siblings.
rootAttachParent :: NodeArena -> Int -> IO Int
rootAttachParent :: NodeArena -> Int -> IO Int
rootAttachParent NodeArena
na Int
parent
  | Int
parent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
parent
  | Bool
otherwise = do
      n <- NodeArena -> IO Int
arenaCount NodeArena
na
      pure (if n > 0 then 0 else -1)

{-# INLINE addNode #-}
addNode ::
  NodeArena ->
  NodeType ->
  Int ->
  Direction ->
  Sizing ->
  Sizing ->
  Padding ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  AlignX ->
  AlignY ->
  IO NodeIdx
addNode :: NodeArena
-> NodeType
-> Int
-> Direction
-> Sizing
-> Sizing
-> Padding
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> AlignX
-> AlignY
-> IO Int
addNode NodeArena
na NodeType
nt Int
parent Direction
dir Sizing
wSiz Sizing
hSiz Padding
pad Float
gap Float
minW Float
minH Float
maxW Float
maxH Float
grow AlignX
ax AlignY
ay = do
  idx <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Int
naCount NodeArena
na)
  ensureCapacity na (idx + 1)
  let (wTag, wVal) = sizingTag wSiz
      (hTag, hVal) = sizingTag hSiz
  a <- arenaArrays na

  setPrimArray (naArrGeom a) (idx * geomStride) geomStride 0

  writeStyle a idx styleWVal wVal
  writeStyle a idx styleHVal hVal
  writeStyle a idx stylePadL (padL pad)
  writeStyle a idx stylePadR (padR pad)
  writeStyle a idx stylePadT (padT pad)
  writeStyle a idx stylePadB (padB pad)
  writeStyle a idx styleGap gap
  writeStyle a idx styleMinW minW
  writeStyle a idx styleMinH minH
  writeStyle a idx styleMaxW maxW
  writeStyle a idx styleMaxH maxH
  writeStyle a idx styleGrow grow
  setPrimArray (naArrStyle a) (idx * styleStride + styleScrollContentW) (styleStride - styleScrollContentW) 0

  setPrimArray (naArrTags a) (idx * tagStride) tagStride 0
  writeTagEnum a idx tagNodeType nt
  writeTagEnum a idx tagDirection $ case dir of
    Direction
Row -> DirTag
DirRow
    Direction
Column -> DirTag
DirColumn
  writeTagEnum a idx tagWSizing wTag
  writeTagEnum a idx tagHSizing hTag
  writeTagEnum a idx tagAlignX ax
  writeTagEnum a idx tagAlignY ay

  setPrimArray (naArrTree a) (idx * treeStride) treeStride 0
  writeTree a idx treeParent parent
  writeTree a idx treeFirstChild (-1)
  writeTree a idx treeNextSibling (-1)
  writeTree a idx treeTextIdx (-1)
  writePrimArray (naArrFontColor a) idx 0
  scope <- readIORef (naScope na)
  writePrimArray (naArrScope a) idx scope
  when (scope /= 0) $ do
    sig <- readIORef (naScopeSig na)
    writeIORef (naScopeSig na) $! (sig * 0x100000001b3) `xor` (fromIntegral idx `shiftL` 32 .|. fromIntegral scope)
  writeArray (naArrOptionsStore a) idx []

  when (parent >= 0) $ do
    fc <- readTree a parent treeFirstChild
    writeTree a idx treeNextSibling fc
    writeTree a parent treeFirstChild idx
    cc <- readTree a parent treeChildCount
    writeTree a parent treeChildCount (cc + 1)
  when (isFloatingNode nt) $ do
    when (nt == NodeModal) $ writeIORef (naTopModal na) idx
    fc <- readIORef (naFloatingCount na)
    writeIORef (naFloatingCount na) (fc + 1)
  writeIORef (naCount na) (idx + 1)
  pure idx

addNodeFromLayout :: NodeArena -> NodeType -> Int -> Layout -> IO NodeIdx
addNodeFromLayout :: NodeArena -> NodeType -> Int -> Layout -> IO Int
addNodeFromLayout NodeArena
na NodeType
nt Int
parent Layout
l = do
  idx <-
    NodeArena
-> NodeType
-> Int
-> Direction
-> Sizing
-> Sizing
-> Padding
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> AlignX
-> AlignY
-> IO Int
addNode
      NodeArena
na
      NodeType
nt
      Int
parent
      (Layout -> Direction
layoutDirection Layout
l)
      (Layout -> Sizing
layoutWidth Layout
l)
      (Layout -> Sizing
layoutHeight Layout
l)
      (Layout -> Padding
layoutPadding Layout
l)
      (Layout -> Float
layoutGap Layout
l)
      (Layout -> Float
layoutMinW Layout
l)
      (Layout -> Float
layoutMinH Layout
l)
      (Layout -> Float
layoutMaxW Layout
l)
      (Layout -> Float
layoutMaxH Layout
l)
      Float
0
      (Layout -> AlignX
layoutAlignX Layout
l)
      (Layout -> AlignY
layoutAlignY Layout
l)
  setGridCols na idx (layoutGridCols l)
  setGridMinColW na idx (layoutGridMinColW l)
  setNodeFontSize na idx (layoutFontSize l)
  setNodeFontColor na idx (layoutFontColor l)
  pure idx

{-# INLINE setNodeText #-}
setNodeText :: NodeArena -> NodeIdx -> Text -> IO ()
setNodeText :: NodeArena -> Int -> Text -> IO ()
setNodeText NodeArena
na Int
idx Text
txt = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  writeArray (naArrTextStore a) idx txt
  writeTree a idx treeTextIdx idx

{-# INLINE getParent #-}
getParent :: NodeArena -> NodeIdx -> IO NodeIdx
getParent :: NodeArena -> Int -> IO Int
getParent NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
treeParent

{-# INLINE getFirstChild #-}
getFirstChild :: NodeArena -> NodeIdx -> IO NodeIdx
getFirstChild :: NodeArena -> Int -> IO Int
getFirstChild NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
treeFirstChild

{-# INLINE getNextSibling #-}
getNextSibling :: NodeArena -> NodeIdx -> IO NodeIdx
getNextSibling :: NodeArena -> Int -> IO Int
getNextSibling NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
treeNextSibling

{-# INLINE getChildCount #-}
getChildCount :: NodeArena -> NodeIdx -> IO Int
getChildCount :: NodeArena -> Int -> IO Int
getChildCount NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
treeChildCount

{-# INLINE getNodeType #-}
getNodeType :: NodeArena -> NodeIdx -> IO NodeType
getNodeType :: NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays
-> (NodeArenaArrays -> IO NodeType) -> IO NodeType
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO NodeType
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagNodeType

{-# INLINE getDirection #-}
getDirection :: NodeArena -> NodeIdx -> IO DirTag
getDirection :: NodeArena -> Int -> IO DirTag
getDirection NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO DirTag) -> IO DirTag
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO DirTag
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagDirection

{-# INLINE getGridCols #-}
getGridCols :: NodeArena -> NodeIdx -> IO Int
getGridCols :: NodeArena -> Int -> IO Int
getGridCols NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
treeGridCols

{-# INLINE setGridCols #-}
setGridCols :: NodeArena -> NodeIdx -> Int -> IO ()
setGridCols :: NodeArena -> Int -> Int -> IO ()
setGridCols NodeArena
na Int
idx Int
c = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> 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
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> Int -> IO ()
writeTree NodeArenaArrays
a Int
idx Int
treeGridCols Int
c

{-# INLINE getWidthSizing #-}
getWidthSizing :: NodeArena -> NodeIdx -> IO (SizingTag, Float)
getWidthSizing :: NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays
-> (NodeArenaArrays -> IO (SizingTag, Float))
-> IO (SizingTag, Float)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> (,) (SizingTag -> Float -> (SizingTag, Float))
-> IO SizingTag -> IO (Float -> (SizingTag, Float))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArenaArrays -> Int -> Int -> IO SizingTag
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagWSizing IO (Float -> (SizingTag, Float))
-> IO Float -> IO (SizingTag, Float)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleWVal

{-# INLINE getHeightSizing #-}
getHeightSizing :: NodeArena -> NodeIdx -> IO (SizingTag, Float)
getHeightSizing :: NodeArena -> Int -> IO (SizingTag, Float)
getHeightSizing NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays
-> (NodeArenaArrays -> IO (SizingTag, Float))
-> IO (SizingTag, Float)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> (,) (SizingTag -> Float -> (SizingTag, Float))
-> IO SizingTag -> IO (Float -> (SizingTag, Float))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArenaArrays -> Int -> Int -> IO SizingTag
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagHSizing IO (Float -> (SizingTag, Float))
-> IO Float -> IO (SizingTag, Float)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleHVal

{-# INLINE getPadding #-}
getPadding :: NodeArena -> NodeIdx -> IO Padding
getPadding :: NodeArena -> Int -> IO Padding
getPadding NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  Padding <$> readStyle a idx stylePadL <*> readStyle a idx stylePadR <*> readStyle a idx stylePadT <*> readStyle a idx stylePadB

{-# INLINE getGap #-}
getGap :: NodeArena -> NodeIdx -> IO Float
getGap :: NodeArena -> Int -> IO Float
getGap NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Float) -> IO Float
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleGap

{-# INLINE getMinMax #-}
getMinMax :: NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getMinMax :: NodeArena -> Int -> IO (Float, Float, Float, Float)
getMinMax NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  (,,,) <$> readStyle a idx styleMinW <*> readStyle a idx styleMinH <*> readStyle a idx styleMaxW <*> readStyle a idx styleMaxH

{-# INLINE getScrollContentW #-}
getScrollContentW :: NodeArena -> NodeIdx -> IO Float
getScrollContentW :: NodeArena -> Int -> IO Float
getScrollContentW NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Float) -> IO Float
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleScrollContentW

{-# INLINE setScrollContentW #-}
setScrollContentW :: NodeArena -> NodeIdx -> Float -> IO ()
setScrollContentW :: NodeArena -> Int -> Float -> IO ()
setScrollContentW NodeArena
na Int
idx Float
v = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> 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
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeStyle NodeArenaArrays
a Int
idx Int
styleScrollContentW Float
v

{-# INLINE getGridMinColW #-}
getGridMinColW :: NodeArena -> NodeIdx -> IO Float
getGridMinColW :: NodeArena -> Int -> IO Float
getGridMinColW NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Float) -> IO Float
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleGridMinColW

{-# INLINE setGridMinColW #-}
setGridMinColW :: NodeArena -> NodeIdx -> Float -> IO ()
setGridMinColW :: NodeArena -> Int -> Float -> IO ()
setGridMinColW NodeArena
na Int
idx Float
v = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> 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
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeStyle NodeArenaArrays
a Int
idx Int
styleGridMinColW Float
v

{-# INLINE parentIsRow #-}
parentIsRow :: NodeArena -> NodeIdx -> IO Bool
parentIsRow :: NodeArena -> Int -> IO Bool
parentIsRow NodeArena
na Int
idx = do
  p <- NodeArena -> Int -> IO Int
getParent NodeArena
na Int
idx
  if p < 0
    then pure False
    else do
      dir <- getDirection na p
      pure (dir == DirRow)

{-# INLINE getAlignX #-}
getAlignX :: NodeArena -> NodeIdx -> IO AlignX
getAlignX :: NodeArena -> Int -> IO AlignX
getAlignX NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO AlignX) -> IO AlignX
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO AlignX
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagAlignX

{-# INLINE getAlignY #-}
getAlignY :: NodeArena -> NodeIdx -> IO AlignY
getAlignY :: NodeArena -> Int -> IO AlignY
getAlignY NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO AlignY) -> IO AlignY
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO AlignY
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagAlignY

{-# INLINE getRect #-}
getRect :: NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect :: NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  (,,,) <$> readGeom a idx geomX <*> readGeom a idx geomY <*> readGeom a idx geomW <*> readGeom a idx geomH

{-# INLINE setRect #-}
setRect :: NodeArena -> NodeIdx -> Float -> Float -> Float -> Float -> IO ()
setRect :: NodeArena -> Int -> Float -> Float -> Float -> Float -> IO ()
setRect NodeArena
na Int
idx Float
x Float
y Float
w Float
h = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  writeGeom a idx geomX x
  writeGeom a idx geomY y
  writeGeom a idx geomW w
  writeGeom a idx geomH h

{-# INLINE getLayoutRect #-}
getLayoutRect :: NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getLayoutRect :: NodeArena -> Int -> IO (Float, Float, Float, Float)
getLayoutRect NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  (,,,) <$> readGeom a idx geomLayoutX <*> readGeom a idx geomLayoutY <*> readGeom a idx geomW <*> readGeom a idx geomH

{-# INLINE getClipRect #-}
getClipRect :: NodeArena -> NodeIdx -> IO (Maybe Rect)
getClipRect :: NodeArena -> Int -> IO (Maybe Rect)
getClipRect NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  x <- readGeom a idx geomClipX
  y <- readGeom a idx geomClipY
  w <- readGeom a idx geomClipW
  h <- readGeom a idx geomClipH
  let r = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
  pure (if w > 0 && h > 0 then Just r else Nothing)

{-# INLINE setClipRect #-}
setClipRect :: NodeArena -> NodeIdx -> Rect -> IO ()
setClipRect :: NodeArena -> Int -> Rect -> IO ()
setClipRect NodeArena
na Int
idx (Rect Float
x Float
y Float
w Float
h) = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  writeGeom a idx geomClipX x
  writeGeom a idx geomClipY y
  writeGeom a idx geomClipW w
  writeGeom a idx geomClipH h

{-# INLINE snapshotLayoutRects #-}
snapshotLayoutRects :: NodeArena -> IO ()
snapshotLayoutRects :: NodeArena -> IO ()
snapshotLayoutRects NodeArena
na = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  forNodes_ na $ \Int
i -> do
    NodeArenaArrays -> Int -> Int -> IO Float
readGeom NodeArenaArrays
a Int
i Int
geomX IO Float -> (Float -> 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
>>= NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeGeom NodeArenaArrays
a Int
i Int
geomLayoutX
    NodeArenaArrays -> Int -> Int -> IO Float
readGeom NodeArenaArrays
a Int
i Int
geomY IO Float -> (Float -> 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
>>= NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeGeom NodeArenaArrays
a Int
i Int
geomLayoutY

-- | Cached layout signature and solved geometry for whole-layout reuse. The
-- backing arrays are reused; only cache misses capture a new solved frame.
-- The font colour and scope columns are paint state and stay unused.
data LayoutCache = LayoutCache
  { LayoutCache -> Int
lcCap :: !Int
  , LayoutCache -> Int
lcCount :: !Int
  , LayoutCache -> NodeArenaArrays
lcArrays :: !NodeArenaArrays
  }

newLayoutCache :: Int -> IO LayoutCache
newLayoutCache :: Int -> IO LayoutCache
newLayoutCache Int
cap0 = do
  let !cap :: Int
cap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
16 Int
cap0
  Int -> Int -> NodeArenaArrays -> LayoutCache
LayoutCache Int
cap Int
0 (NodeArenaArrays -> LayoutCache)
-> IO NodeArenaArrays -> IO LayoutCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO NodeArenaArrays
newNodeArenaArrays Int
cap

-- | Snapshot the current (post-solve) arena form, constraints and rects.
captureLayoutCache :: NodeArena -> LayoutCache -> IO LayoutCache
captureLayoutCache :: NodeArena -> LayoutCache -> IO LayoutCache
captureLayoutCache NodeArena
na LayoutCache
lc0 = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  let !oldCap = LayoutCache -> Int
lcCap LayoutCache
lc0
      !newCap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n (Int
oldCap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
  lc <-
    if n <= oldCap
      then pure lc0
      else LayoutCache newCap (lcCount lc0) <$> growNodeArenaArrays oldCap newCap (lcArrays lc0)
  a <- arenaArrays na
  let c = LayoutCache -> NodeArenaArrays
lcArrays LayoutCache
lc
  copyMutablePrimArray (naArrGeom c) 0 (naArrGeom a) 0 (n * geomStride)
  copyMutablePrimArray (naArrStyle c) 0 (naArrStyle a) 0 (n * styleStride)
  copyMutablePrimArray (naArrTags c) 0 (naArrTags a) 0 (n * tagStride)
  copyMutablePrimArray (naArrTree c) 0 (naArrTree a) 0 (n * treeStride)
  copyMutableArray (naArrTextStore c) 0 (naArrTextStore a) 0 n
  copyMutableArray (naArrOptionsStore c) 0 (naArrOptionsStore a) 0 n
  pure lc {lcCount = n}

-- | Floating placement depends on state outside the arena descriptor. Custom
-- measurement is checked separately by Frame, which owns its registration.
layoutCacheEligible :: NodeArena -> IO Bool
layoutCacheEligible :: NodeArena -> IO Bool
layoutCacheEligible NodeArena
na = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  a <- arenaArrays na
  if n <= 0
    then pure False
    else allRangeM 0 n $ \Int
i -> Bool -> Bool
not (Bool -> Bool) -> (NodeType -> Bool) -> NodeType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeType -> Bool
isFloatingNode (NodeType -> Bool) -> IO NodeType -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArenaArrays -> Int -> Int -> IO NodeType
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
i Int
tagNodeType

-- | Compare layout inputs, stopping at the first mismatch. Node values are
-- paint state except on scroll containers, where they are solver outputs.
-- Neither belongs in the layout-input signature.
layoutInputsMatch :: NodeArena -> LayoutCache -> IO Bool
layoutInputsMatch :: NodeArena -> LayoutCache -> IO Bool
layoutInputsMatch NodeArena
na LayoutCache
lc = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  if n <= 0 || n /= lcCount lc
    then pure False
    else do
      -- The cache only holds eligible layouts, and matching node types
      -- keep the current one eligible too.
      a <- arenaArrays na
      let c = LayoutCache -> NodeArenaArrays
lcArrays LayoutCache
lc
      andThen (styleMatch (naArrStyle a) (naArrStyle c) n) $
        andThen (allRangeM 0 (n * tagStride) (\Int
k -> if Int
k Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. (Int
tagStride Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tagScrollBarSlot then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True else MutablePrimArray RealWorld Word8
-> MutablePrimArray RealWorld Word8 -> Int -> IO Bool
forall a.
(Prim a, Eq a) =>
MutablePrimArray RealWorld a
-> MutablePrimArray RealWorld a -> Int -> IO Bool
primEqAt (NodeArenaArrays -> MutablePrimArray RealWorld Word8
naArrTags NodeArenaArrays
a) (NodeArenaArrays -> MutablePrimArray RealWorld Word8
naArrTags NodeArenaArrays
c) Int
k)) $
          andThen (treeMatch a (naArrTree c) n) $
            andThen (allRangeM 0 n (boxedEqAt (naArrTextStore a) (naArrTextStore c))) $
              allRangeM 0 n (boxedEqAt (naArrOptionsStore a) (naArrOptionsStore c))

{-# INLINE andThen #-}
andThen :: IO Bool -> IO Bool -> IO Bool
andThen :: IO Bool -> IO Bool -> IO Bool
andThen IO Bool
check IO Bool
next = do
  ok <- IO Bool
check
  if ok then next else pure False

-- | Whether @p@ holds at every index in @[lo, hi)@, stopping at the first miss.
{-# INLINE allRangeM #-}
allRangeM :: Int -> Int -> (Int -> IO Bool) -> IO Bool
allRangeM :: Int -> Int -> (Int -> IO Bool) -> IO Bool
allRangeM Int
lo Int
hi Int -> IO Bool
p = Int -> IO Bool
go Int
lo
  where
    go :: Int -> IO Bool
go !Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hi = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      | Bool
otherwise = do
          ok <- Int -> IO Bool
p Int
i
          if ok then go (i + 1) else pure False

{-# INLINE primEqAt #-}
primEqAt :: (Prim a, Eq a) => MutablePrimArray RealWorld a -> MutablePrimArray RealWorld a -> Int -> IO Bool
primEqAt :: forall a.
(Prim a, Eq a) =>
MutablePrimArray RealWorld a
-> MutablePrimArray RealWorld a -> Int -> IO Bool
primEqAt MutablePrimArray RealWorld a
x MutablePrimArray RealWorld a
y Int
i = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> IO a -> IO (a -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutablePrimArray (PrimState IO) a -> Int -> IO a
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
x Int
i IO (a -> Bool) -> IO a -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MutablePrimArray (PrimState IO) a -> Int -> IO a
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
y Int
i

{-# INLINE boxedEqAt #-}
boxedEqAt :: Eq a => MutableArray RealWorld a -> MutableArray RealWorld a -> Int -> IO Bool
boxedEqAt :: forall a.
Eq a =>
MutableArray RealWorld a
-> MutableArray RealWorld a -> Int -> IO Bool
boxedEqAt MutableArray RealWorld a
x MutableArray RealWorld a
y Int
i = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> IO a -> IO (a -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) a -> Int -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld a
MutableArray (PrimState IO) a
x Int
i IO (a -> Bool) -> IO a -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MutableArray (PrimState IO) a -> Int -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld a
MutableArray (PrimState IO) a
y Int
i

-- The scroll-extent and node-value columns hold solver outputs or paint-only
-- values, so they are skipped.
styleMatch :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Int -> IO Bool
styleMatch :: MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float -> Int -> IO Bool
styleMatch MutablePrimArray RealWorld Float
x MutablePrimArray RealWorld Float
y Int
n =
  Int -> Int -> (Int -> IO Bool) -> IO Bool
allRangeM Int
0 Int
n ((Int -> IO Bool) -> IO Bool) -> (Int -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Int
i ->
    let !base :: Int
base = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
styleStride
     in IO Bool -> IO Bool -> IO Bool
andThen (Int -> Int -> (Int -> IO Bool) -> IO Bool
allRangeM Int
base (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
styleScrollContentW) (MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float -> Int -> IO Bool
forall a.
(Prim a, Eq a) =>
MutablePrimArray RealWorld a
-> MutablePrimArray RealWorld a -> Int -> IO Bool
primEqAt MutablePrimArray RealWorld Float
x MutablePrimArray RealWorld Float
y)) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
          Int -> Int -> (Int -> IO Bool) -> IO Bool
allRangeM (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
styleGridMinColW) (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
styleStride) (MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float -> Int -> IO Bool
forall a.
(Prim a, Eq a) =>
MutablePrimArray RealWorld a
-> MutablePrimArray RealWorld a -> Int -> IO Bool
primEqAt MutablePrimArray RealWorld Float
x MutablePrimArray RealWorld Float
y)

-- Box/image/drawing style IDs are paint data; their intrinsic dimensions come
-- from sizing constraints. The grid column count only matters to containers.
treeMatch :: NodeArenaArrays -> MutablePrimArray RealWorld Int -> Int -> IO Bool
treeMatch :: NodeArenaArrays -> MutablePrimArray RealWorld Int -> Int -> IO Bool
treeMatch NodeArenaArrays
a MutablePrimArray RealWorld Int
cached Int
n =
  Int -> Int -> (Int -> IO Bool) -> IO Bool
allRangeM Int
0 Int
n ((Int -> IO Bool) -> IO Bool) -> (Int -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    nt <- NodeArenaArrays -> Int -> Int -> IO NodeType
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
i Int
tagNodeType
    let paintStyle = NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeBox Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeImage Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeDrawing
        !base = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
treeStride
    allRangeM 0 treeStride $ \Int
j ->
      if (Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
treeStyleIdx Bool -> Bool -> Bool
&& Bool
paintStyle) Bool -> Bool -> Bool
|| (Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
treeGridCols Bool -> Bool -> Bool
&& Bool -> Bool
not (NodeType -> Bool
isContainerNode NodeType
nt))
        then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool) -> IO Int -> IO (Int -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
i Int
j IO (Int -> Bool) -> IO Int -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MutablePrimArray (PrimState IO) Int -> Int -> IO Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
cached (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)

-- | Restore only solver outputs. Rebuilt paint values/colors must survive a
-- cache hit; copying the entire cached style array would revert them.
restoreLayoutCache :: NodeArena -> LayoutCache -> IO ()
restoreLayoutCache :: NodeArena -> LayoutCache -> IO ()
restoreLayoutCache NodeArena
na LayoutCache
lc = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  let !n = LayoutCache -> Int
lcCount LayoutCache
lc
      c = LayoutCache -> NodeArenaArrays
lcArrays LayoutCache
lc
  copyMutablePrimArray (naArrGeom a) 0 (naArrGeom c) 0 (n * geomStride)
  let go !Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = do
            nt <- NodeArenaArrays -> Int -> Int -> IO NodeType
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
i Int
tagNodeType
            -- Scroll content width, node value (the content height) and
            -- scrollbar slot.
            when (isScrollNode nt) $ do
              let !off = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
styleStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
styleScrollContentW
                  !slotOff = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tagStride Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tagScrollBarSlot
              copyMutablePrimArray (naArrStyle a) off (naArrStyle c) off 2
              readPrimArray (naArrTags c) slotOff >>= writePrimArray (naArrTags a) slotOff
            go (i + 1)
  go 0

{-# INLINE getText #-}
getText :: NodeArena -> NodeIdx -> IO Text
getText :: NodeArena -> Int -> IO Text
getText NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  ti <- readTree a idx treeTextIdx
  if ti < 0
    then pure T.empty
    else readArray (naArrTextStore a) ti

{-# INLINE getOptions #-}
getOptions :: NodeArena -> NodeIdx -> IO [Text]
getOptions :: NodeArena -> Int -> IO [Text]
getOptions NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  readArray (naArrOptionsStore a) idx

{-# INLINE setOptions #-}
setOptions :: NodeArena -> NodeIdx -> [Text] -> IO ()
setOptions :: NodeArena -> Int -> [Text] -> IO ()
setOptions NodeArena
na Int
idx [Text]
opts = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  writeArray (naArrOptionsStore a) idx opts

{-# INLINE getWidgetId #-}
getWidgetId :: NodeArena -> NodeIdx -> IO WidgetId
getWidgetId :: NodeArena -> Int -> IO WidgetId
getWidgetId NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays
-> (NodeArenaArrays -> IO WidgetId) -> IO WidgetId
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> Word64 -> WidgetId
WidgetId (Word64 -> WidgetId) -> (Int -> Word64) -> Int -> WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WidgetId) -> IO Int -> IO WidgetId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
treeWidgetId

{-# INLINE packEpochNode #-}
packEpochNode :: Word32 -> NodeIdx -> Word64
packEpochNode :: Word32 -> Int -> Word64
packEpochNode !Word32
epoch !Int
idx = (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
epoch Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xFFFFFFFF)

{-# INLINE unpackEpochNode #-}
unpackEpochNode :: Word64 -> (Word32, NodeIdx)
unpackEpochNode :: Word64 -> (Word32, Int)
unpackEpochNode !Word64
w = (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32), Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xFFFFFFFF))

{-# INLINE setWidgetId #-}
setWidgetId :: NodeArena -> NodeIdx -> WidgetId -> IO ()
setWidgetId :: NodeArena -> Int -> WidgetId -> IO ()
setWidgetId NodeArena
na Int
idx WidgetId
wid = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  let WidgetId w = wid
  writeTree a idx treeWidgetId (fromIntegral w)
  when (hashWidgetId wid /= 0) $ do
    !ep <- readIORef (naEpoch na)
    table <- readIORef (naIndex na)
    HT.insert table wid (packEpochNode ep idx)

{-# INLINE lookupNodeByWidgetId #-}
lookupNodeByWidgetId :: NodeArena -> WidgetId -> IO (Maybe NodeIdx)
lookupNodeByWidgetId :: NodeArena -> WidgetId -> IO (Maybe Int)
lookupNodeByWidgetId NodeArena
na WidgetId
wid
  | WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      table <- IORef (HashTable RealWorld WidgetId Word64)
-> IO (HashTable RealWorld WidgetId Word64)
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef (BasicHashTable WidgetId Word64)
naIndex NodeArena
na)
      mVal <- HT.lookup table wid
      case mVal of
        Maybe Word64
Nothing -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
        Just Word64
val -> do
          !ep <- IORef Word32 -> IO Word32
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Word32
naEpoch NodeArena
na)
          let (!entryEp, !idx) = unpackEpochNode val
          pure (if entryEp == ep then Just idx else Nothing)

{-# INLINE lookupNodeByKey #-}
lookupNodeByKey :: NodeArena -> Int -> IO (Maybe NodeIdx)
lookupNodeByKey :: NodeArena -> Int -> IO (Maybe Int)
lookupNodeByKey NodeArena
na Int
key = NodeArena -> WidgetId -> IO (Maybe Int)
lookupNodeByWidgetId NodeArena
na (Word64 -> WidgetId
WidgetId (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
key))

{-# INLINE getNodeValue #-}
getNodeValue :: NodeArena -> NodeIdx -> IO Float
getNodeValue :: NodeArena -> Int -> IO Float
getNodeValue NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Float) -> IO Float
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleNodeValue

{-# INLINE setNodeValue #-}
setNodeValue :: NodeArena -> NodeIdx -> Float -> IO ()
setNodeValue :: NodeArena -> Int -> Float -> IO ()
setNodeValue NodeArena
na Int
idx Float
v = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> 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
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeStyle NodeArenaArrays
a Int
idx Int
styleNodeValue Float
v

{-# INLINE getNodeFontSize #-}
getNodeFontSize :: NodeArena -> NodeIdx -> IO Float
getNodeFontSize :: NodeArena -> Int -> IO Float
getNodeFontSize NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Float) -> IO Float
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleFontSize

{-# INLINE setNodeFontSize #-}
setNodeFontSize :: NodeArena -> NodeIdx -> Float -> IO ()
setNodeFontSize :: NodeArena -> Int -> Float -> IO ()
setNodeFontSize NodeArena
na Int
idx Float
v = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> 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
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> Float -> IO ()
writeStyle NodeArenaArrays
a Int
idx Int
styleFontSize Float
v

-- | Per-node font color (paint-only, kept out of @naArrTree@
-- where 'treeGridCols' holds the grid column count for containers).
{-# INLINE getNodeFontColor #-}
getNodeFontColor :: NodeArena -> NodeIdx -> IO (Maybe Color)
getNodeFontColor :: NodeArena -> Int -> IO (Maybe Color)
getNodeFontColor NodeArena
na Int
idx = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  val <- readPrimArray (naArrFontColor a) idx
  if (val .&. 0x100000000) /= 0
    then pure (Just (Color (fromIntegral (val .&. 0xFFFFFFFF))))
    else pure Nothing

{-# INLINE setNodeFontColor #-}
setNodeFontColor :: NodeArena -> NodeIdx -> Maybe Color -> IO ()
setNodeFontColor :: NodeArena -> Int -> Maybe Color -> IO ()
setNodeFontColor NodeArena
na Int
idx Maybe Color
mCol = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  let val = case Maybe Color
mCol of
        Maybe Color
Nothing -> Int
0
        Just (Color Word32
w) -> Int
0x100000000 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w
  writePrimArray (naArrFontColor a) idx val

{-# INLINE getNodeScope #-}
getNodeScope :: NodeArena -> NodeIdx -> IO Int
getNodeScope :: NodeArena -> Int -> IO Int
getNodeScope NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> MutablePrimArray (PrimState IO) Int -> Int -> IO Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray (NodeArenaArrays -> MutablePrimArray RealWorld Int
naArrScope NodeArenaArrays
a) Int
idx

{-# INLINE getArenaScope #-}
getArenaScope :: NodeArena -> IO Int
getArenaScope :: NodeArena -> IO Int
getArenaScope NodeArena
na = IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Int
naScope NodeArena
na)

{-# INLINE setArenaScope #-}
setArenaScope :: NodeArena -> Int -> IO ()
setArenaScope :: NodeArena -> Int -> IO ()
setArenaScope NodeArena
na = IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (NodeArena -> IORef Int
naScope NodeArena
na)

{-# INLINE getScopeSignature #-}
getScopeSignature :: NodeArena -> IO Word64
getScopeSignature :: NodeArena -> IO Word64
getScopeSignature NodeArena
na = IORef Word64 -> IO Word64
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Word64
naScopeSig NodeArena
na)

{-# INLINE getStyleIdx #-}
getStyleIdx :: NodeArena -> NodeIdx -> IO Int
getStyleIdx :: NodeArena -> Int -> IO Int
getStyleIdx NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> IO Int
readTree NodeArenaArrays
a Int
idx Int
treeStyleIdx

{-# INLINE setStyleIdx #-}
setStyleIdx :: NodeArena -> NodeIdx -> Int -> IO ()
setStyleIdx :: NodeArena -> Int -> Int -> IO ()
setStyleIdx NodeArena
na Int
idx Int
v = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays -> (NodeArenaArrays -> 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
>>= \NodeArenaArrays
a -> NodeArenaArrays -> Int -> Int -> Int -> IO ()
writeTree NodeArenaArrays
a Int
idx Int
treeStyleIdx Int
v

-- | Get the snapshot buffers for a recursion depth, grown to hold at least
-- @needed@ entries. Buffers are reused across frames; nothing is allocated in
-- steady state once capacity is warm.
{-# NOINLINE ensureAxisSnapshot #-}
ensureAxisSnapshot :: NodeArena -> Int -> Int -> IO AxisSnapshot
ensureAxisSnapshot :: NodeArena -> Int -> Int -> IO AxisSnapshot
ensureAxisSnapshot NodeArena
na Int
depth Int
needed = do
  arr0 <- IORef (MutableArray RealWorld (Maybe AxisSnapshot))
-> IO (MutableArray RealWorld (Maybe AxisSnapshot))
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef (MutableArray RealWorld (Maybe AxisSnapshot))
naSnapLevels NodeArena
na)
  let !d = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
depth
  arr <- ensureSnapLevelsArr na arr0 (d + 1)
  cap <- readIORef (naSnapCap na)
  if needed <= cap
    then getLevel arr d cap
    else do
      let !newCap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
needed (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
          !levels = MutableArray RealWorld (Maybe AxisSnapshot) -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld (Maybe AxisSnapshot)
arr
      forM_ [0 .. levels - 1] $ \Int
i -> do
        m <- MutableArray (PrimState IO) (Maybe AxisSnapshot)
-> Int -> IO (Maybe AxisSnapshot)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld (Maybe AxisSnapshot)
MutableArray (PrimState IO) (Maybe AxisSnapshot)
arr Int
i
        case m of
          Maybe AxisSnapshot
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just (AxisSnapshot MutablePrimArray RealWorld Int
idx MutablePrimArray RealWorld Float
out) -> do
            idx' <- MutablePrimArray RealWorld Int
-> Int -> Int -> Int -> IO (MutablePrimArray RealWorld Int)
forall a.
Prim a =>
MutablePrimArray RealWorld a
-> Int -> Int -> a -> IO (MutablePrimArray RealWorld a)
growPrimArrayCopy MutablePrimArray RealWorld Int
idx Int
cap Int
newCap Int
0
            out' <- growPrimArrayCopy out cap newCap 0
            writeArray arr i (Just (AxisSnapshot idx' out'))
      writeIORef (naSnapCap na) newCap
      getLevel arr d newCap
  where
    getLevel :: MutableArray (PrimState m) (Maybe AxisSnapshot)
-> Int -> Int -> m AxisSnapshot
getLevel MutableArray (PrimState m) (Maybe AxisSnapshot)
arr Int
d Int
currentCap = do
      m <- MutableArray (PrimState m) (Maybe AxisSnapshot)
-> Int -> m (Maybe AxisSnapshot)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray (PrimState m) (Maybe AxisSnapshot)
arr Int
d
      case m of
        Just AxisSnapshot
s -> AxisSnapshot -> m AxisSnapshot
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AxisSnapshot
s
        Maybe AxisSnapshot
Nothing -> do
          asIdx <- Int -> m (MutablePrimArray (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
currentCap
          asOut <- newPrimArray currentCap
          let s = MutablePrimArray RealWorld Int
-> MutablePrimArray RealWorld Float -> AxisSnapshot
AxisSnapshot MutablePrimArray RealWorld Int
asIdx MutablePrimArray RealWorld Float
asOut
          writeArray arr d (Just s)
          pure s

-- | Grow the per-depth snapshot-level array to hold at least @need@ levels,
-- so nesting depth has no fixed limit.
ensureSnapLevelsArr :: NodeArena -> MutableArray RealWorld (Maybe AxisSnapshot) -> Int -> IO (MutableArray RealWorld (Maybe AxisSnapshot))
ensureSnapLevelsArr :: NodeArena
-> MutableArray RealWorld (Maybe AxisSnapshot)
-> Int
-> IO (MutableArray RealWorld (Maybe AxisSnapshot))
ensureSnapLevelsArr NodeArena
na MutableArray RealWorld (Maybe AxisSnapshot)
arr Int
need = do
  let !sz :: Int
sz = MutableArray RealWorld (Maybe AxisSnapshot) -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld (Maybe AxisSnapshot)
arr
  if Int
need Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
sz
    then MutableArray RealWorld (Maybe AxisSnapshot)
-> IO (MutableArray RealWorld (Maybe AxisSnapshot))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableArray RealWorld (Maybe AxisSnapshot)
arr
    else do
      let !newSz :: Int
newSz = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
need (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
      arr' <- Int
-> Maybe AxisSnapshot
-> IO (MutableArray (PrimState IO) (Maybe AxisSnapshot))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
newSz Maybe AxisSnapshot
forall a. Maybe a
Nothing
      copyMutableArray arr' 0 arr 0 sz
      writeIORef (naSnapLevels na) arr'
      pure arr'

-- | Memoize @compute@ for node @idx@ at width @key@ in one of the arena's
-- per-frame memos. Widths within 0.25 px share an entry so near-identical
-- reflows still hit.
{-# INLINE memoizeWidth #-}
memoizeWidth :: NodeArena -> IORef WidthMemo -> NodeIdx -> Float -> IO (Float, Float) -> IO (Float, Float)
memoizeWidth :: NodeArena
-> IORef WidthMemo
-> Int
-> Float
-> IO (Float, Float)
-> IO (Float, Float)
memoizeWidth NodeArena
na IORef WidthMemo
ref Int
idx Float
key IO (Float, Float)
compute = do
  ft <- IORef Word32 -> IO Word32
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef Word32
naFrameTag NodeArena
na)
  WidthMemo tags slots <- readIORef ref
  tag <- readPrimArray tags idx
  let !base = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
memoStride
  hit <-
    if tag /= ft
      then pure False
      else do
        k <- readPrimArray slots base
        pure (abs (k - key) <= 0.25)
  if hit
    then (,) <$> readPrimArray slots (base + 1) <*> readPrimArray slots (base + 2)
    else do
      r@(x, y) <- compute
      WidthMemo tags' slots' <- readIORef ref
      writePrimArray tags' idx ft
      writePrimArray slots' base key
      writePrimArray slots' (base + 1) x
      writePrimArray slots' (base + 2) y
      pure r

-- | The flex scratch, grown to hold at least @needed@ entries.
{-# INLINE ensureScratchCapacity #-}
ensureScratchCapacity :: NodeArena -> Int -> IO FlexScratch
ensureScratchCapacity :: NodeArena -> Int -> IO FlexScratch
ensureScratchCapacity NodeArena
na Int
needed = do
  s <- IORef FlexScratch -> IO FlexScratch
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef FlexScratch
naScratch NodeArena
na)
  if needed <= fsCap s then pure s else growScratch na s needed

{-# NOINLINE growScratch #-}
growScratch :: NodeArena -> FlexScratch -> Int -> IO FlexScratch
growScratch :: NodeArena -> FlexScratch -> Int -> IO FlexScratch
growScratch NodeArena
na FlexScratch
s Int
needed = do
  let !cap :: Int
cap = FlexScratch -> Int
fsCap FlexScratch
s
      !newCap :: Int
newCap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
needed (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
  fsIdx <- MutablePrimArray RealWorld Int
-> Int -> Int -> Int -> IO (MutablePrimArray RealWorld Int)
forall a.
Prim a =>
MutablePrimArray RealWorld a
-> Int -> Int -> a -> IO (MutablePrimArray RealWorld a)
growPrimArrayCopy (FlexScratch -> MutablePrimArray RealWorld Int
fsIdx FlexScratch
s) Int
cap Int
newCap (-Int
1)
  fsW <- growPrimArrayCopy (fsW s) cap newCap 0
  fsH <- growPrimArrayCopy (fsH s) cap newCap 0
  fsOutW <- growPrimArrayCopy (fsOutW s) cap newCap 0
  fsOutH <- growPrimArrayCopy (fsOutH s) cap newCap 0
  let s' = FlexScratch {fsCap :: Int
fsCap = Int
newCap, MutablePrimArray RealWorld Float
MutablePrimArray RealWorld Int
fsIdx :: MutablePrimArray RealWorld Int
fsW :: MutablePrimArray RealWorld Float
fsH :: MutablePrimArray RealWorld Float
fsOutW :: MutablePrimArray RealWorld Float
fsOutH :: MutablePrimArray RealWorld Float
fsIdx :: MutablePrimArray RealWorld Int
fsW :: MutablePrimArray RealWorld Float
fsH :: MutablePrimArray RealWorld Float
fsOutW :: MutablePrimArray RealWorld Float
fsOutH :: MutablePrimArray RealWorld Float
..}
  writeIORef (naScratch na) s'
  pure s'

{-# INLINE forNodes_ #-}
forNodes_ :: NodeArena -> (NodeIdx -> IO ()) -> IO ()
forNodes_ :: NodeArena -> (Int -> IO ()) -> IO ()
forNodes_ NodeArena
na Int -> IO ()
f = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  let go !Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = Int -> IO ()
f Int
i IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  go 0

{-# INLINE forChildNodes_ #-}
forChildNodes_ :: NodeArena -> NodeIdx -> (NodeIdx -> IO ()) -> IO ()
forChildNodes_ :: NodeArena -> Int -> (Int -> IO ()) -> IO ()
forChildNodes_ NodeArena
na Int
parentIdx Int -> IO ()
f = do
  fc <- NodeArena -> Int -> IO Int
getFirstChild NodeArena
na Int
parentIdx
  let 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
            Int -> IO ()
f Int
ci
            ns <- NodeArena -> Int -> IO Int
getNextSibling NodeArena
na Int
ci
            go ns
  go fc

-- | Fold over a node's children in sibling order, skipping floating
-- (modal, window, popup) children, which are placed outside the flow.
{-# INLINE foldFlowChildrenM #-}
foldFlowChildrenM :: NodeArena -> NodeIdx -> (acc -> NodeIdx -> IO acc) -> acc -> IO acc
foldFlowChildrenM :: forall acc.
NodeArena -> Int -> (acc -> Int -> IO acc) -> acc -> IO acc
foldFlowChildrenM NodeArena
na Int
parentIdx acc -> Int -> IO acc
f acc
z = do
  fc <- NodeArena -> Int -> IO Int
getFirstChild NodeArena
na Int
parentIdx
  let go !Int
ci !acc
acc
        | Int
ci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = acc -> IO acc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure acc
acc
        | Bool
otherwise = do
            nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
ci
            ns <- getNextSibling na ci
            if isFloatingNode nt
              then go ns acc
              else f acc ci >>= go ns
  go fc z

{-# INLINE findNodeRevM #-}
findNodeRevM :: NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findNodeRevM :: NodeArena -> (Int -> IO Bool) -> IO (Maybe Int)
findNodeRevM NodeArena
na Int -> IO Bool
p = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  let go !Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            ok <- Int -> IO Bool
p Int
i
            if ok then pure (Just i) else go (i - 1)
  go (n - 1)


{-# INLINE foldNodeRevM #-}
foldNodeRevM :: NodeArena -> (a -> NodeIdx -> IO a) -> a -> IO a
foldNodeRevM :: forall a. NodeArena -> (a -> Int -> IO a) -> a -> IO a
foldNodeRevM NodeArena
na a -> Int -> IO a
f a
z = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  let go !Int
i !a
acc
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc
        | Bool
otherwise = do
            acc' <- a -> Int -> IO a
f a
acc Int
i
            go (i - 1) acc'
  go (n - 1) z

-- ---------------------------------------------------------------------------
-- Frame traversal helpers: forward node scans and child searches, shaped like
-- 'forNodes_' and 'findNodeRevM'.
-- ---------------------------------------------------------------------------

-- | First node, in arena order, satisfying the predicate.
{-# INLINE findNodeM #-}
findNodeM :: NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findNodeM :: NodeArena -> (Int -> IO Bool) -> IO (Maybe Int)
findNodeM NodeArena
na Int -> IO Bool
p = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  let go !Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            ok <- Int -> IO Bool
p Int
i
            if ok then pure (Just i) else go (i + 1)
  go 0

-- | Left fold over every node in arena order.
{-# INLINE foldNodesM #-}
foldNodesM :: NodeArena -> (a -> NodeIdx -> IO a) -> a -> IO a
foldNodesM :: forall a. NodeArena -> (a -> Int -> IO a) -> a -> IO a
foldNodesM NodeArena
na a -> Int -> IO a
f a
z = do
  n <- NodeArena -> IO Int
arenaCount NodeArena
na
  let go !Int
i !a
acc
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc
        | Bool
otherwise = a -> Int -> IO a
f a
acc Int
i IO a -> (a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> a -> IO a
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  go 0 z

-- | First direct child of @parentIdx@ satisfying the predicate.
{-# INLINE findChildM #-}
findChildM :: NodeArena -> NodeIdx -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findChildM :: NodeArena -> Int -> (Int -> IO Bool) -> IO (Maybe Int)
findChildM NodeArena
na Int
parentIdx Int -> IO Bool
p = do
  fc <- NodeArena -> Int -> IO Int
getFirstChild NodeArena
na Int
parentIdx
  let go !Int
ci
        | Int
ci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            ok <- Int -> IO Bool
p Int
ci
            if ok then pure (Just ci) else getNextSibling na ci >>= go
  go fc