-- | The layout solver: measures and places the node arena's flow tree, then
-- positions modals, windows and popups.
module NanoUI.Layout.Solve
  ( solveLayout
  , FontResolver
  , Measurers (..)
  , placeModals
  , placeWindows
  , placePopups
  , computePopupPosition
  , placeWindowNode
  , scrollBarSlotOf
  , findAncestorMaxW
  , textWrapCap
  ) where

import Control.Monad (foldM, forM, unless, when)
import Data.IORef (readIORef)
import Data.Maybe (fromMaybe)
import Data.Primitive.PrimArray
  ( MutablePrimArray
  , copyMutablePrimArray
  , newPrimArray
  , readPrimArray
  , writePrimArray
  )
import Data.Primitive.Types (Prim)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word8)
import GHC.Exts (RealWorld)
import NanoUI.Font
  ( CustomMeasureFn
  , FontMetrics (..)
  , checkboxBoxSize
  , checkboxLeading
  , treeRowLeading
  , treeItemPadding
  , classifyScrollBar
  , measureTextIO
  , lineWidthIO
  , measureTextWrappedIO
  , tableCellInset
  , ScrollBarSlot (..)
  , widgetPadding
  , buttonPadding
  , menuItemPadX
  , menuOuterPad
  , selectPadding
  , isDefaultNodeFont
  , sliderTrackHeight
  , sliderHandleDiameter
  , sliderHandleSlack
  , centeredTextY
  )
import NanoUI.Layout.Arena
  ( DirTag (..)
  , FlexScratch (..)
  , NodeArena
  , NodeArenaArrays
  , NodeIdx
  , NodeType (..)
  , SizingTag (..)
  , arenaArrays
  , arenaCount
  , hasCenteredLabel
  , withArenaArraysSnap
  , geomX
  , geomY
  , geomW
  , geomH
  , styleWVal
  , styleHVal
  , styleMinW
  , styleMinH
  , styleMaxW
  , styleMaxH
  , stylePadL
  , stylePadR
  , stylePadT
  , stylePadB
  , styleGap
  , styleGridMinColW
  , tagNodeType
  , tagDirection
  , treeStyleIdx
  , treeGridCols
  , tagWSizing
  , tagHSizing
  , tagScrollBarSlot
  , readGeom
  , writeTagEnum
  , writeGeom
  , readStyle
  , readTagEnum
  , readTree
  , treeParent
  , getAlignX
  , getAlignY
  , getChildCount
  , getDirection
  , getFirstChild
  , getGap
  , getGridCols
  , getGridMinColW
  , getHeightSizing
  , getMinMax
  , getNodeType
  , getOptions
  , getParent
  , getStyleIdx
  , getPadding
  , getRect
  , getText
  , getWidgetId
  , getWidthSizing
  , parentIsRow
  , isContainerNode
  , isFloatingNode
  , isScrollNode
  , setRect
  , getNodeValue
  , setNodeValue
  , getNodeFontSize
  , getScrollContentW
  , setScrollContentW
  , ensureScratchCapacity
  , AxisSnapshot (..)
  , ensureAxisSnapshot
  , memoizeWidth
  , forNodes_
  , foldFlowChildrenM
  , naScratch
  , naWrapMemo
  , naFitMemo
  )
import NanoUI.Id (WidgetId)
import NanoUI.Style (AlignX (..), AlignY (..), FontStyle (..), FontVariant (..), FontWeight (..), Padding (..), windowMargin)
import NanoUI.Types (PopupAnchor (..), PopupPlacement (..), Rect (..), V2 (..), clamp, onGrid)
import NanoUI.WidgetText
  ( colorPickerSvH
  , textNodeFontVariant
  , textNodeFontWeight
  , textNodeFontStyle
  , treeDecodeStyle
  , selectDisplayText
  , selectChevronReserve
  , textInputFieldHeight
  , textInputMinWidth
  , textInputSearchMode
  , textInputNumericMode
  , numericStepperW
  , textInputSelectableMode
  , searchFieldReserveW
  , isTableHeaderStyle
  , isMenuItemStyle
  , isCloseButtonStyle
  , tableHeaderDisplayText
  )
import NanoUI.Frame.Scroll.Geometry
  ( decodeScrollConfig
  , isScrollStyle2D
  , scrollAxisGutter
  , scrollGutters2D
  , scrollPolicyX
  , scrollPolicyY
  )

type FontResolver = Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Text -> IO (Float, Float))

-- | Per-solve constants threaded through the measure and position passes.
data SolveEnv = SolveEnv
  { SolveEnv -> NodeArena
seArena :: !NodeArena
  , SolveEnv -> NodeArenaArrays
seArrays :: !NodeArenaArrays
  , SolveEnv -> FontMetrics
seFm :: !FontMetrics
  , SolveEnv -> FontMetrics
seMonoFm :: !FontMetrics
  , SolveEnv -> Text -> IO (Float, Float)
seMeasure :: !(Text -> IO (Float, Float))
  , SolveEnv -> FontResolver
seResolveFont :: !FontResolver
  , SolveEnv -> WidgetId -> IO (Maybe CustomMeasureFn)
seLookupMeasure :: !(WidgetId -> IO (Maybe CustomMeasureFn))
  }

-- | How text and custom widgets are measured. The solve and the placement of
-- floating nodes after it measure with the same, so a label placed in a modal
-- wraps exactly as the solve measured it for the modal's size.
data Measurers = Measurers
  { Measurers -> FontMetrics
msFm :: !FontMetrics
  , Measurers -> FontMetrics
msMonoFm :: !FontMetrics
  , Measurers -> Text -> IO (Float, Float)
msMeasure :: !(Text -> IO (Float, Float))
  , Measurers -> FontResolver
msResolveFont :: !FontResolver
  , Measurers -> WidgetId -> IO (Maybe CustomMeasureFn)
msLookupMeasure :: !(WidgetId -> IO (Maybe CustomMeasureFn))
  }

solveEnv :: NodeArena -> Measurers -> IO SolveEnv
solveEnv :: NodeArena -> Measurers -> IO SolveEnv
solveEnv NodeArena
na Measurers {FontMetrics
msFm :: Measurers -> FontMetrics
msFm :: FontMetrics
msFm, FontMetrics
msMonoFm :: Measurers -> FontMetrics
msMonoFm :: FontMetrics
msMonoFm, Text -> IO (Float, Float)
msMeasure :: Measurers -> Text -> IO (Float, Float)
msMeasure :: Text -> IO (Float, Float)
msMeasure, FontResolver
msResolveFont :: Measurers -> FontResolver
msResolveFont :: FontResolver
msResolveFont, WidgetId -> IO (Maybe CustomMeasureFn)
msLookupMeasure :: Measurers -> WidgetId -> IO (Maybe CustomMeasureFn)
msLookupMeasure :: WidgetId -> IO (Maybe CustomMeasureFn)
msLookupMeasure} = do
  a <- NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na
  pure (SolveEnv na a msFm msMonoFm msMeasure msResolveFont msLookupMeasure)

-- | Strict accumulator for flow-child folds: a child count and two running
-- sums or extents. The strict fields keep the folds unboxed.
data FlowAcc = FlowAcc !Int !Float !Float

-- Keep font selection and single-line/wrapped measurement together so every
-- layout pass uses the same policy. Monospaced text uses its metrics directly;
-- proportional text uses the host's shaping-aware measurement callback.
data TextMeasurer = TextMeasurer
  { TextMeasurer -> FontMetrics
tmMetrics :: !FontMetrics
  , TextMeasurer -> FontVariant
tmVariant :: !FontVariant
  , TextMeasurer -> Text -> IO (Float, Float)
tmHostLine :: Text -> IO (Float, Float)
  }

textNodeMeasurer :: SolveEnv -> NodeIdx -> IO TextMeasurer
textNodeMeasurer :: SolveEnv -> Int -> IO TextMeasurer
textNodeMeasurer SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
fm, seMonoFm :: SolveEnv -> FontMetrics
seMonoFm = FontMetrics
monoFm, seMeasure :: SolveEnv -> Text -> IO (Float, Float)
seMeasure = Text -> IO (Float, Float)
measure, seResolveFont :: SolveEnv -> FontResolver
seResolveFont = FontResolver
resolveFont} Int
idx = do
  si <- NodeArena -> Int -> IO Int
getStyleIdx NodeArena
na Int
idx
  size <- getNodeFontSize na idx
  let variant = Int -> FontVariant
textNodeFontVariant Int
si
      weight = Int -> FontWeight
textNodeFontWeight Int
si
      style = Int -> FontStyle
textNodeFontStyle Int
si
  (metrics, measureLine) <-
    if isDefaultNodeFont size weight style variant
      then pure (if variant == FontMono then monoFm else fm, measure)
      else resolveFont size weight style variant
  pure (TextMeasurer metrics variant measureLine)

-- Keep these operations as inline functions rather than allocating two
-- closures for every resolved node, including nodes that never wrap.
{-# INLINE measureFontLine #-}
measureFontLine :: TextMeasurer -> Text -> IO (Float, Float)
measureFontLine :: TextMeasurer -> Text -> IO (Float, Float)
measureFontLine TextMeasurer {tmMetrics :: TextMeasurer -> FontMetrics
tmMetrics = FontMetrics
metrics, tmVariant :: TextMeasurer -> FontVariant
tmVariant = FontVariant
variant, tmHostLine :: TextMeasurer -> Text -> IO (Float, Float)
tmHostLine = Text -> IO (Float, Float)
hostLine} Text
text
  | FontVariant
variant FontVariant -> FontVariant -> Bool
forall a. Eq a => a -> a -> Bool
== FontVariant
FontMono = FontMetrics -> Text -> IO (Float, Float)
measureTextIO FontMetrics
metrics Text
text
  | Bool
otherwise = Text -> IO (Float, Float)
hostLine Text
text

{-# INLINE measureFontWrapped #-}
measureFontWrapped :: TextMeasurer -> Text -> Float -> IO (Float, Float)
measureFontWrapped :: TextMeasurer -> Text -> Float -> IO (Float, Float)
measureFontWrapped TextMeasurer {tmMetrics :: TextMeasurer -> FontMetrics
tmMetrics = FontMetrics
metrics, tmVariant :: TextMeasurer -> FontVariant
tmVariant = FontVariant
variant, tmHostLine :: TextMeasurer -> Text -> IO (Float, Float)
tmHostLine = Text -> IO (Float, Float)
hostLine} Text
text Float
width
  | FontVariant
variant FontVariant -> FontVariant -> Bool
forall a. Eq a => a -> a -> Bool
== FontVariant
FontMono = (Text -> IO Float)
-> FontMetrics -> Text -> Float -> IO (Float, Float)
measureTextWrappedIO (FontMetrics -> Text -> IO Float
lineWidthIO FontMetrics
metrics) FontMetrics
metrics Text
text Float
width
  | Bool
otherwise = (Text -> IO Float)
-> FontMetrics -> Text -> Float -> IO (Float, Float)
measureTextWrappedIO (((Float, Float) -> Float) -> IO (Float, Float) -> IO Float
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Float, Float) -> Float
forall a b. (a, b) -> a
fst (IO (Float, Float) -> IO Float)
-> (Text -> IO (Float, Float)) -> Text -> IO Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO (Float, Float)
hostLine) FontMetrics
metrics Text
text Float
width

-- | A measured text node: whether it wrapped, its content size, and the line
-- height of its font.
data TextBox = TextBox
  { TextBox -> Bool
tbWrapped :: !Bool
  , TextBox -> Float
tbW :: !Float
  , TextBox -> Float
tbH :: !Float
  , TextBox -> Float
tbLineH :: !Float
  }

-- | Measure a text node's content for the width @outerW@. The text wraps at
-- @outerW@ minus its label inset when it has explicit newlines, or when
-- @shouldWrap wrapW lineW@ holds for its single-line width.
measureTextNodeAt :: SolveEnv -> NodeIdx -> Text -> Float -> (Float -> Float -> Bool) -> IO TextBox
measureTextNodeAt :: SolveEnv
-> Int -> Text -> Float -> (Float -> Float -> Bool) -> IO TextBox
measureTextNodeAt SolveEnv
env Int
idx Text
txt Float
outerW Float -> Float -> Bool
shouldWrap = do
  measurer@TextMeasurer {tmMetrics = textFm} <- SolveEnv -> Int -> IO TextMeasurer
textNodeMeasurer SolveEnv
env Int
idx
  (tw0, th0) <- measureFontLine measurer txt
  let wrapW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
outerW
      lineH = FontMetrics -> Float
fmLineHeight FontMetrics
textFm
      na = SolveEnv -> NodeArena
seArena SolveEnv
env
  if T.any (== '\n') txt || shouldWrap wrapW tw0
    then do
      (tw, th) <- memoizeWidth na (naWrapMemo na) idx wrapW (measureFontWrapped measurer txt wrapW)
      pure (TextBox True tw th lineH)
    else pure (TextBox False tw0 th0 lineH)

-- | Wrap policy once a width is assigned: wrap when allowed and the single
-- line overflows a positive wrap width.
{-# INLINE wrapsNarrower #-}
wrapsNarrower :: Bool -> Float -> Float -> Bool
wrapsNarrower :: Bool -> Float -> Float -> Bool
wrapsNarrower Bool
allowed Float
wrapW Float
lineW = Bool
allowed Bool -> Bool -> Bool
&& Float
wrapW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
lineW Bool -> Bool -> Bool
&& Float
wrapW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0

solveLayout :: NodeArena -> Measurers -> Float -> Float -> IO ()
solveLayout :: NodeArena -> Measurers -> Float -> Float -> IO ()
solveLayout NodeArena
na Measurers
ms Float
rootW Float
rootH =
  NodeArena -> IO () -> IO ()
forall a. NodeArena -> IO a -> IO a
withArenaArraysSnap NodeArena
na (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    count <- NodeArena -> IO Int
arenaCount NodeArena
na
    when (count > 0) $ do
      env <- solveEnv na ms
      measurePass env count
      positionNodeA env 0 0 0 0 rootW rootH
      quantizeResultsA (seArrays env) count (fmSnapScale (msFm ms))

quantizeResultsA :: NodeArenaArrays -> Int -> Float -> IO ()
quantizeResultsA :: NodeArenaArrays -> Int -> Float -> IO ()
quantizeResultsA NodeArenaArrays
a Int
count Float
s
  | Float
s Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = do
      -- A floating node (modal, window, popup) and everything inside it is
      -- laid out by placement after the solve, which sizes the subtree from
      -- these measured sizes. Rounding them here would size a dialog and its
      -- content-sized parts off their content, so the subtree keeps them;
      -- placement overwrites its geometry anyway. A parent always precedes
      -- its children, so one pass marks each node from its parent.
      floating <- Int -> IO (MutablePrimArray (PrimState IO) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
count :: IO (MutablePrimArray RealWorld Word8)
      let go Int
i
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
count = () -> 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
                parent <- readTree a i treeParent
                inFloating <-
                  if isFloatingNode nt
                    then pure True
                    else if parent >= 0 then (/= 0) <$> readPrimArray floating parent else pure False
                writePrimArray floating i (if inFloating then 1 else 0)
                unless inFloating $ do
                  x <- readGeom a i geomX
                  y <- readGeom a i geomY
                  w <- readGeom a i geomW
                  h <- readGeom a i geomH
                  writeGeom a i geomX (onGrid s x)
                  writeGeom a i geomY (onGrid s y)
                  writeGeom a i geomW (max 0 (onGrid s w))
                  writeGeom a i geomH (max 0 (onGrid s h))
                go (i + 1)
      go 0

measurePass :: SolveEnv -> Int -> IO ()
measurePass :: SolveEnv -> Int -> IO ()
measurePass SolveEnv
env Int
count = do
  let go :: Int -> IO ()
go !Int
idx
        | Int
idx 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
            SolveEnv -> Int -> IO ()
measureNode SolveEnv
env Int
idx
            Int -> IO ()
go (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Int -> IO ()
go (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

measureNode :: SolveEnv -> NodeIdx -> IO ()
measureNode :: SolveEnv -> Int -> IO ()
measureNode env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
fm} Int
idx = do
  nt <- NodeArenaArrays -> Int -> Int -> IO NodeType
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum (SolveEnv -> NodeArenaArrays
seArrays SolveEnv
env) Int
idx Int
tagNodeType
  case nt of
    NodeType
NodeText -> SolveEnv -> Int -> IO ()
measureTextNode SolveEnv
env Int
idx
    NodeType
NodeSpacer -> NodeArena -> Int -> IO ()
measureSpacer NodeArena
na Int
idx
    NodeType
NodeSeparator -> NodeArena -> Int -> IO ()
measureSeparator NodeArena
na Int
idx
    NodeType
NodeScrollContainer -> SolveEnv -> Int -> IO ()
measureScrollContainer SolveEnv
env Int
idx
    NodeType
NodeImage -> NodeArena -> Int -> IO ()
measureImage NodeArena
na Int
idx
    NodeType
NodeBox -> NodeArena -> Int -> IO ()
measureImage NodeArena
na Int
idx
    NodeType
NodeDrawing -> do
      wid <- NodeArena -> Int -> IO WidgetId
getWidgetId NodeArena
na Int
idx
      mFn <- seLookupMeasure env wid
      case mFn of
        Just CustomMeasureFn
fn -> NodeArena -> FontMetrics -> CustomMeasureFn -> Int -> IO ()
measureCustomNode NodeArena
na FontMetrics
fm CustomMeasureFn
fn Int
idx
        Maybe CustomMeasureFn
Nothing -> NodeArena -> Int -> IO ()
measureImage NodeArena
na Int
idx
    NodeType
_
      | NodeType -> Bool
isContainerNode NodeType
nt -> do
          SolveEnv -> Int -> IO ()
measureContainer SolveEnv
env Int
idx
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeModal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ NodeArena -> Int -> Float -> IO ()
setNodeValue NodeArena
na Int
idx Float
0
      | Bool
otherwise -> SolveEnv -> Int -> IO ()
measureWidget SolveEnv
env Int
idx

measureCustomNode ::
  NodeArena ->
  FontMetrics ->
  CustomMeasureFn ->
  NodeIdx ->
  IO ()
measureCustomNode :: NodeArena -> FontMetrics -> CustomMeasureFn -> Int -> IO ()
measureCustomNode NodeArena
na FontMetrics
fm CustomMeasureFn
measureFn Int
idx = do
  (minW, minH, maxW, maxH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getMinMax NodeArena
na Int
idx
  (wTag, wVal) <- getWidthSizing na idx
  (hTag, hVal) <- getHeightSizing na idx
  let availW = case SizingTag
wTag of SizingTag
SizingFixed -> Float
wVal; SizingTag
_ -> if Float
maxW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8 then Float
maxW else Float
1e9
      availH = case SizingTag
hTag of SizingTag
SizingFixed -> Float
hVal; SizingTag
_ -> if Float
maxH Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8 then Float
maxH else Float
1e9
      (mw, mh) = measureFn fm (availW, availH)
      w = case SizingTag
wTag of SizingTag
SizingFixed -> Float
wVal; SizingTag
_ -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW Float
mw
      h = case SizingTag
hTag of SizingTag
SizingFixed -> Float
hVal; SizingTag
_ -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH Float
mh
  setRect na idx 0 0 w h

-- | The width a text node that is not a row's child wraps at, from its
-- effective max width, width sizing and assigned width: 1e8 or more when
-- nothing caps it ('collectNodeTextSpans').
textWrapCap :: Float -> SizingTag -> Float -> Float
textWrapCap :: Float -> SizingTag -> Float -> Float
textWrapCap Float
effMaxW SizingTag
wTag Float
w
  | Float
effMaxW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8 = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
effMaxW
  | SizingTag
wTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingGrow Bool -> Bool -> Bool
&& Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 = Float
w
  | Bool
otherwise = Float
effMaxW

findAncestorMaxW :: NodeArena -> NodeIdx -> IO Float
findAncestorMaxW :: NodeArena -> Int -> IO Float
findAncestorMaxW NodeArena
na Int
idx = Int -> Float -> IO Float
go Int
idx Float
0
  where
    go :: Int -> Float -> IO Float
go Int
cur !Float
padAccum = do
      p <- NodeArena -> Int -> IO Int
getParent NodeArena
na Int
cur
      if p < 0
        then pure 1e9
        else do
          pad <- getPadding na p
          let padAccum' = Float
padAccum Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padL Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padR Padding
pad
          (_, _, pMaxW, _) <- getMinMax na p
          (pwTag, pwVal) <- getWidthSizing na p
          if pwTag == SizingFixed
            then pure (max 0 (pwVal - padAccum'))
            else if pMaxW < 1e8
              then pure (max 0 (pMaxW - padAccum'))
              else go p padAccum'

measureTextNode :: SolveEnv -> NodeIdx -> IO ()
measureTextNode :: SolveEnv -> Int -> IO ()
measureTextNode env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na} Int
idx = do
  (minW, minH, maxW, maxH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getMinMax NodeArena
na Int
idx
  (wTag, _) <- getWidthSizing na idx
  (hTag, hVal) <- getHeightSizing na idx
  parentAssigns <- growParent na idx
  txt <- getText na idx
  isRowChild <- parentIsRow na idx
  effMaxW <-
    if maxW < 1e8
      then pure maxW
      else findAncestorMaxW na idx
  let canWrap = Bool -> Bool
not Bool
isRowChild Bool -> Bool -> Bool
&& Float
effMaxW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8
  TextBox {tbW = tw, tbH = th, tbLineH = lineH} <-
    measureTextNodeAt env idx txt effMaxW (\Float
_ Float
lineW -> Bool
canWrap Bool -> Bool -> Bool
&& Float
effMaxW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
lineW)
  let reportedW =
        if SizingTag
wTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingGrow Bool -> Bool -> Bool
&& Bool
parentAssigns
          then Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW Float
0
          else Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW Float
tw
  setRect na idx 0 0 reportedW $
    case hTag of
      SizingTag
SizingFixed -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH Float
hVal
      SizingTag
_ -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
lineH Float
th)

-- | Whether a grow-width node's width is assigned from above rather than
-- reported: its parent grows, and the nearest ancestor that does not grow is
-- not a modal. A modal takes its width from what it holds, so a grow label
-- inside one still reports its natural width; otherwise the modal could never
-- widen for it and the label would wrap into more lines than the modal
-- measured. Windows keep their own width and truncate long lines instead.
growParent :: NodeArena -> NodeIdx -> IO Bool
growParent :: NodeArena -> Int -> IO Bool
growParent NodeArena
na Int
idx = NodeArena -> Int -> IO Int
getParent NodeArena
na Int
idx IO Int -> (Int -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Int -> IO Bool
go Bool
True
  where
    go :: Bool -> Int -> IO Bool
go Bool
isParent Int
p
      | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bool
not Bool
isParent)
      | Bool
otherwise = do
          (pwTag, _) <- NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
p
          if pwTag == SizingGrow
            then getParent na p >>= go False
            else
              if isParent
                then pure False
                else do
                  nt <- getNodeType na p
                  pure (nt /= NodeModal)

measureImage :: NodeArena -> NodeIdx -> IO ()
measureImage :: NodeArena -> Int -> IO ()
measureImage NodeArena
na Int
idx = do
  (minW, minH, maxW, maxH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getMinMax NodeArena
na Int
idx
  (wTag, wVal) <- getWidthSizing na idx
  (hTag, hVal) <- getHeightSizing na idx
  let w =
        case SizingTag
wTag of
          SizingTag
SizingFixed -> Float
wVal
          SizingTag
_ -> if Float
minW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
minW else Float
32
      h =
        case SizingTag
hTag of
          SizingTag
SizingFixed -> Float
hVal
          SizingTag
_ -> if Float
minH Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
minH else Float
32
  setRect na idx 0 0 (clamp minW maxW w) (clamp minH maxH h)

measureSpacer :: NodeArena -> NodeIdx -> IO ()
measureSpacer :: NodeArena -> Int -> IO ()
measureSpacer NodeArena
na Int
idx = do
  (wTag, wVal) <- NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
idx
  (hTag, hVal) <- getHeightSizing na idx
  -- Non-fixed spacers reserve the default 8px extent.
  let w = if SizingTag
wTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingFixed then Float
wVal else Float
8
      h = if SizingTag
hTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingFixed then Float
hVal else Float
8
  setRect na idx 0 0 w h

measureSeparator :: NodeArena -> NodeIdx -> IO ()
measureSeparator :: NodeArena -> Int -> IO ()
measureSeparator NodeArena
na Int
idx = do
  dir <- NodeArena -> Int -> IO DirTag
getDirection NodeArena
na Int
idx
  case dir of
    DirTag
DirRow -> NodeArena -> Int -> Float -> Float -> Float -> Float -> IO ()
setRect NodeArena
na Int
idx Float
0 Float
0 Float
1 Float
20
    DirTag
DirColumn -> NodeArena -> Int -> Float -> Float -> Float -> Float -> IO ()
setRect NodeArena
na Int
idx Float
0 Float
0 Float
20 Float
1

{-# INLINE measureMarkedWidget #-}
measureMarkedWidget ::
  FontMetrics ->
  (Text -> IO (Float, Float)) ->
  Text ->
  Float ->
  IO (Float, Float, Float, Float)
measureMarkedWidget :: FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> Float
-> IO (Float, Float, Float, Float)
measureMarkedWidget FontMetrics
fm Text -> IO (Float, Float)
measure Text
body Float
leading = do
  (mw, mh) <- Text -> IO (Float, Float)
measure (if Text -> Bool
T.null Text
body then Text
" " else Text
body)
  pure (mw, max mh (checkboxBoxSize fm), leading, 0)

measureTextField ::
  FontMetrics ->
  (Text -> IO (Float, Float)) ->
  Text ->
  Bool ->
  IO (Float, Float, Float, Float)
measureTextField :: FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> Bool
-> IO (Float, Float, Float, Float)
measureTextField FontMetrics
fm Text -> IO (Float, Float)
measure Text
txt Bool
multiline = do
  pw <- if Bool
multiline Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
txt then Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0 else (Float, Float) -> Float
forall a b. (a, b) -> a
fst ((Float, Float) -> Float) -> IO (Float, Float) -> IO Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO (Float, Float)
measure Text
txt
  let fieldH = if Bool
multiline then Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
96 (FontMetrics -> Float
textInputFieldHeight FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
4) else FontMetrics -> Float
textInputFieldHeight FontMetrics
fm
      contentW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
textInputMinWidth Float
pw
  pure (contentW, fieldH, 0, 0)

-- Caption-less search box: single row tall, icons counted in the width budget.
measureSearchField ::
  FontMetrics ->
  (Text -> IO (Float, Float)) ->
  Text ->
  IO (Float, Float, Float, Float)
measureSearchField :: FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> IO (Float, Float, Float, Float)
measureSearchField FontMetrics
fm Text -> IO (Float, Float)
measure Text
txt = do
  let lbl :: Text
lbl = if Text -> Bool
T.null Text
txt then Text
" " else Text
txt
  (lw, _) <- Text -> IO (Float, Float)
measure Text
lbl
  let contentW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
textInputMinWidth Float
lw Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Float
searchFieldReserveW FontMetrics
fm
  pure (contentW, textInputFieldHeight fm, 0, 0)

measureWidget :: SolveEnv -> NodeIdx -> IO ()
measureWidget :: SolveEnv -> Int -> IO ()
measureWidget env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seArrays :: SolveEnv -> NodeArenaArrays
seArrays = NodeArenaArrays
a, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
fm, seMeasure :: SolveEnv -> Text -> IO (Float, Float)
seMeasure = Text -> IO (Float, Float)
measure} Int
idx = do
  nt <- NodeArenaArrays -> Int -> Int -> IO NodeType
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagNodeType
  txt <- getText na idx
  si <- readTree a idx treeStyleIdx
  minW <- readStyle a idx styleMinW
  minH <- readStyle a idx styleMinH
  maxW <- readStyle a idx styleMaxW
  maxH <- readStyle a idx styleMaxH
  wTag <- readTagEnum a idx tagWSizing
  wVal <- readStyle a idx styleWVal
  hTag <- readTagEnum a idx tagHSizing
  hVal <- readStyle a idx styleHVal
  let (padX, padY) =
        case nt of
          NodeType
NodeButton
            | Int -> Bool
isTableHeaderStyle Int
si ->
                (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
tableCellInset, Float
0)
            -- Menu rows reserve the same gutter the text-field context menu
            -- paints (outer pad + item pad on each side of the label), so the
            -- generic popup panel sizes identically.
            | Int -> Bool
isMenuItemStyle Int
si ->
                (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
menuOuterPad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
menuItemPadX), (Float, Float) -> Float
forall a b. (a, b) -> b
snd (FontMetrics -> (Float, Float)
buttonPadding FontMetrics
fm))
            | Bool
otherwise -> FontMetrics -> (Float, Float)
buttonPadding FontMetrics
fm
          NodeType
NodeSelect -> FontMetrics -> (Float, Float)
selectPadding FontMetrics
fm
          NodeType
NodeTree -> FontMetrics -> (Float, Float)
treeItemPadding FontMetrics
fm
          NodeType
NodeTextInput
            | Int -> Bool
textInputSelectableMode Int
si -> (Float
0, Float
0)
          NodeType
_
            | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeColorPicker
                Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeSlider
                Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeCheckbox
                Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeRadio
                Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTextInput
                Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTextArea ->
                (Float
0, Float
0)
            | Bool
otherwise -> FontMetrics -> (Float, Float)
widgetPadding FontMetrics
fm
  (tw, th, extraW, extraH) <-
    case nt of
      NodeType
NodeSlider -> do
        let contentW :: Float
contentW = Float
60
            contentH :: Float
contentH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
sliderHandleDiameter (Float
sliderTrackHeight Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
sliderHandleSlack)
        (Float, Float, Float, Float) -> IO (Float, Float, Float, Float)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float
contentW, Float
contentH, Float
0, Float
0)
      NodeType
NodeTree -> do
        let (Int
_, Int
depth, Bool
_, Bool
_) = Int -> (Int, Int, Bool, Bool)
treeDecodeStyle Int
si
        FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> Float
-> IO (Float, Float, Float, Float)
measureMarkedWidget FontMetrics
fm Text -> IO (Float, Float)
measure Text
txt (FontMetrics -> Int -> Float
treeRowLeading FontMetrics
fm Int
depth)
      NodeType
NodeSelect -> do
        opts <- NodeArena -> Int -> IO [Text]
getOptions NodeArena
na Int
idx
        let choices = if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
opts then [Text
""] else [Text]
opts
        (mw, mh) <-
          foldM
            (\(!Float
mw, !Float
mh) Text
c -> (\(Float
w, Float
h) -> (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
mw Float
w, Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
mh Float
h)) ((Float, Float) -> (Float, Float))
-> IO (Float, Float) -> IO (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO (Float, Float)
measure (Text -> Text -> Text
selectDisplayText Text
txt Text
c))
            (0, 0)
            choices
        pure (mw, mh, selectChevronReserve, 0)
      -- Picker parts carry fixed layouts; the field grows to its square.
      NodeType
NodeColorPicker -> (Float, Float, Float, Float) -> IO (Float, Float, Float, Float)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float
0, Float
colorPickerSvH, Float
0, Float
0)
      NodeType
NodeTextInput
        | Int -> Bool
textInputSelectableMode Int
si -> do
            -- Size with the node's own font (paint and span placement resolve
            -- it too); the ambient `measure` is the default font only.
            measurer <- SolveEnv -> Int -> IO TextMeasurer
textNodeMeasurer SolveEnv
env Int
idx
            (mw, mh) <- measureFontLine measurer (if T.null txt then " " else txt)
            pure (mw, mh, 0, 0)
        -- Numeric field: a short editable box and its stepper.
        | Int -> Bool
textInputNumericMode Int
si ->
            (Float, Float, Float, Float) -> IO (Float, Float, Float, Float)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float
56, FontMetrics -> Float
textInputFieldHeight FontMetrics
fm, Float
numericStepperW, Float
0)
        | Int -> Bool
textInputSearchMode Int
si ->
            FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> IO (Float, Float, Float, Float)
measureSearchField FontMetrics
fm Text -> IO (Float, Float)
measure Text
txt
        | Bool
otherwise -> FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> Bool
-> IO (Float, Float, Float, Float)
measureTextField FontMetrics
fm Text -> IO (Float, Float)
measure Text
txt Bool
False
      NodeType
NodeTextArea -> FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> Bool
-> IO (Float, Float, Float, Float)
measureTextField FontMetrics
fm Text -> IO (Float, Float)
measure Text
txt Bool
True
      NodeType
_
        | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeCheckbox Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeRadio ->
            FontMetrics
-> (Text -> IO (Float, Float))
-> Text
-> Float
-> IO (Float, Float, Float, Float)
measureMarkedWidget FontMetrics
fm Text -> IO (Float, Float)
measure Text
txt (FontMetrics -> Float
checkboxLeading FontMetrics
fm)
        | Bool
otherwise -> do
            body <-
              if Text -> Bool
T.null Text
txt
                then Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
" "
                else
                  if Int -> Bool
isTableHeaderStyle Int
si
                    then Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text
tableHeaderDisplayText Text
txt)
                    else Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
txt
            (mw, mh) <- measure body
            pure (mw, mh, 0, 0)
  let rawW = Float
tw Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
padX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
extraW
      rawH = Float
th Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
padY Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
extraH
      w = case SizingTag
wTag of SizingTag
SizingFixed -> Float
wVal; SizingTag
_ -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW Float
rawW
      h = case SizingTag
hTag of SizingTag
SizingFixed -> Float
hVal; SizingTag
_ -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH Float
rawH
  setRect na idx 0 0 w h

measureContainer :: SolveEnv -> NodeIdx -> IO ()
measureContainer :: SolveEnv -> Int -> IO ()
measureContainer env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seArrays :: SolveEnv -> NodeArenaArrays
seArrays = NodeArenaArrays
a} Int
idx = do
  (pad, gap, dir) <- NodeArenaArrays -> Int -> IO (Padding, Float, DirTag)
containerFlow NodeArenaArrays
a Int
idx
  gCols <- readTree a idx treeGridCols
  minColW <- readStyle a idx styleGridMinColW
  minW <- readStyle a idx styleMinW
  minH <- readStyle a idx styleMinH
  maxW <- readStyle a idx styleMaxW
  maxH <- readStyle a idx styleMaxH
  wTag <- readTagEnum a idx tagWSizing
  wVal <- readStyle a idx styleWVal
  hTag <- readTagEnum a idx tagHSizing
  hVal <- readStyle a idx styleHVal
  nt <- readTagEnum a idx tagNodeType
  let chrome = NodeType -> DirTag -> Bool
isChromeColumn NodeType
nt DirTag
dir
      padX = Padding -> Float
padL Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padR Padding
pad
      padY = Padding -> Float
padT Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padB Padding
pad
      innerMaxW =
        case SizingTag
wTag of
          SizingTag
SizingFixed -> Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
wVal Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
padX)
          SizingTag
_ -> Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
maxW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
padX)
      innerAvailH =
        case SizingTag
hTag of
          SizingTag
SizingFixed -> Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
hVal Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
padY)
          SizingTag
_ -> Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
maxH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
padY)
  (contentW, contentH) <-
    if gCols > 0 || minColW > 0
      then measureGridScratch env idx gCols minColW innerMaxW innerAvailH gap
      else if dir == DirColumn && chrome
        then do
          n <- loadChildrenScratch na idx (flowChildSize env False innerMaxW innerAvailH)
          foldChromeColumnScratch na n gap
        else foldChildDimsFromParent env idx dir gap
  -- A grow container with its own minimum width, whose width is assigned from
  -- above, reports that minimum rather than its content: it shrinks that far
  -- in a row that is short of space, so that is the least it needs. As with
  -- CSS's min-width on a flex item, the explicit minimum replaces the
  -- content-based one. Otherwise a 2D scroller, which lays its content out at
  -- the width it reports, scrolls sideways for a long label in a cell that
  -- would have fit. Without a minimum the content still counts, so a grow
  -- wrapper around a wide table keeps its sideways scroll.
  minAssigned <-
    if wTag == SizingGrow && minW > 0 && not (isFloatingNode nt)
      then growParent na idx
      else pure False
  let w =
        case SizingTag
wTag of
          SizingTag
SizingFixed -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW Float
wVal
          SizingTag
_
            | Bool
minAssigned -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW Float
0
            | Bool
otherwise -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW (Float
contentW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
padX)
      h =
        case SizingTag
hTag of
          SizingTag
SizingFixed -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH Float
hVal
          SizingTag
_ -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH (Float
contentH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
padY)
  setRect na idx 0 0 w h

measureScrollContainer :: SolveEnv -> NodeIdx -> IO ()
measureScrollContainer :: SolveEnv -> Int -> IO ()
measureScrollContainer env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seArrays :: SolveEnv -> NodeArenaArrays
seArrays = NodeArenaArrays
a} Int
idx = do
  (pad, gap, dir) <- NodeArenaArrays -> Int -> IO (Padding, Float, DirTag)
containerFlow NodeArenaArrays
a Int
idx
  let padX = Padding -> Float
padL Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padR Padding
pad
      padY = Padding -> Float
padT Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padB Padding
pad
  si <- getStyleIdx na idx
  (minW, minH, maxW, maxH) <- getMinMax na idx
  (wTag, wVal) <- getWidthSizing na idx
  (hTag, hVal) <- getHeightSizing na idx
  (contentW, contentH) <- foldChildDimsFromParent env idx dir gap
  parent <- getParent na idx
  -- A modal's body scrolls like a window's: its bar sits just inside the
  -- panel's edge, out in the panel padding.
  isWin <-
    if parent < 0
      then pure False
      else do
        pnt <- getNodeType na parent
        pure (pnt == NodeWindow || pnt == NodeModal)
  inPanel <- hasPanelAncestor na parent
  let slot = Bool -> Bool -> ScrollBarSlot
classifyScrollBar Bool
isWin (SizingTag
wTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingGrow Bool -> Bool -> Bool
&& SizingTag
hTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingGrow Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inPanel)
  writeTagEnum a idx tagScrollBarSlot slot
  let fullW = Float
contentW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
padX
      fullH = Float
contentH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
padY
      assignedInnerH =
        case SizingTag
hTag of
          SizingTag
SizingFixed -> Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
hVal Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
padY)
          SizingTag
_ -> Float
contentH
      cfg = Int -> ScrollConfig
decodeScrollConfig Int
si
      fitGutterW
        | SizingTag
wTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingGrow Bool -> Bool -> Bool
|| SizingTag
wTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingFixed = Float
0
        | Int -> Bool
isScrollStyle2D Int
si = Float
0
        | Bool
otherwise =
            case DirTag
dir of
              DirTag
DirColumn -> ScrollPolicy -> ScrollBarSlot -> Float -> Float -> Float -> Float
scrollAxisGutter (ScrollConfig -> ScrollPolicy
scrollPolicyY ScrollConfig
cfg) ScrollBarSlot
slot (Padding -> Float
padR Padding
pad) Float
contentH Float
assignedInnerH
              DirTag
DirRow -> Float
0
      viewportW =
        case SizingTag
wTag of
          SizingTag
SizingFixed -> Float
wVal
          SizingTag
_ -> Float
fullW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
fitGutterW
      viewportH =
        case SizingTag
hTag of
          SizingTag
SizingFixed -> Float
hVal
          SizingTag
_ -> Float
fullH
  if isScrollStyle2D si
    then do
      setNodeValue na idx contentH
      setScrollContentW na idx contentW
    else setNodeValue na idx (case dir of DirTag
DirColumn -> Float
contentH; DirTag
DirRow -> Float
contentW)
  setRect na idx 0 0 (clamp minW maxW viewportW) (clamp minH maxH viewportH)

foldChildDimsFromParent :: SolveEnv -> NodeIdx -> DirTag -> Float -> IO (Float, Float)
foldChildDimsFromParent :: SolveEnv -> Int -> DirTag -> Float -> IO (Float, Float)
foldChildDimsFromParent env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na} Int
idx DirTag
dir Float
gap = do
  FlowAcc count main cross <- NodeArena
-> Int -> (FlowAcc -> Int -> IO FlowAcc) -> FlowAcc -> IO FlowAcc
forall acc.
NodeArena -> Int -> (acc -> Int -> IO acc) -> acc -> IO acc
foldFlowChildrenM NodeArena
na Int
idx FlowAcc -> Int -> IO FlowAcc
step (Int -> Float -> Float -> FlowAcc
FlowAcc Int
0 Float
0 Float
0)
  -- A row's baseline-aligned children stand on one line, so together they are
  -- as tall as the most room any takes above it plus the most any takes below.
  baseline <-
    if dir == DirRow
      then foldFlowChildrenM na idx baselineStep (0, 0)
      else pure (0, 0)
  pure
    ( case dir of
        DirTag
DirRow ->
          ( Float
main Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
          , if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then Float
0 else Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
cross ((Float -> Float -> Float) -> (Float, Float) -> Float
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Float -> Float -> Float
forall a. Num a => a -> a -> a
(+) (Float, Float)
baseline)
          )
        DirTag
DirColumn ->
          ( if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then Float
0 else Float
main
          , Float
cross Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
          )
    )
  where
    step :: FlowAcc -> Int -> IO FlowAcc
step (FlowAcc Int
count Float
main Float
cross) Int
ci = do
      (_, _, w, h) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect NodeArena
na Int
ci
      pure $
        case dir of
          DirTag
DirRow -> Int -> Float -> Float -> FlowAcc
FlowAcc (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Float
main Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
cross Float
h)
          DirTag
DirColumn -> Int -> Float -> Float -> FlowAcc
FlowAcc (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
main Float
w) (Float
cross Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h)
    baselineStep :: (Float, Float) -> Int -> IO (Float, Float)
baselineStep acc :: (Float, Float)
acc@(Float
above, Float
below) Int
ci = do
      ay <- NodeArena -> Int -> IO AlignY
getAlignY NodeArena
na Int
ci
      if ay /= AlignBaseline
        then pure acc
        else do
          (_, _, _, h) <- getRect na ci
          b <- childBaseline env ci h
          pure (max above b, max below (h - b))

isChromeColumn :: NodeType -> DirTag -> Bool
isChromeColumn :: NodeType -> DirTag -> Bool
isChromeColumn NodeType
nt DirTag
dir =
  DirTag
dir DirTag -> DirTag -> Bool
forall a. Eq a => a -> a -> Bool
== DirTag
DirColumn 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
NodeModal)

-- | Gap before child @b@ in a column; chrome columns drop it before separators.
pairColumnGap :: NodeArena -> Bool -> NodeIdx -> Float -> IO Float
pairColumnGap :: NodeArena -> Bool -> Int -> Float -> IO Float
pairColumnGap NodeArena
_ Bool
False Int
_ Float
gap = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
gap
pairColumnGap NodeArena
na Bool
True Int
b Float
gap = do
  ntB <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
b
  pure (if ntB == NodeSeparator then 0 else gap)

foldChromeColumnScratch :: NodeArena -> Int -> Float -> IO (Float, Float)
foldChromeColumnScratch :: NodeArena -> Int -> Float -> IO (Float, Float)
foldChromeColumnScratch NodeArena
na Int
n Float
gap = do
  FlexScratch {fsW = wArr, fsH = hArr} <- IORef FlexScratch -> IO FlexScratch
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef FlexScratch
naScratch NodeArena
na)
  gapSum <- columnGapSumScratch na True n gap
  let go !Int
i !Float
maxW !Float
totalH
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = (Float, Float) -> IO (Float, Float)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float
maxW, Float
totalH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gapSum)
        | Bool
otherwise = do
            w <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
wArr Int
i
            h <- readPrimArray hArr i
            go (i + 1) (max maxW w) (totalH + h)
  go 0 0 0

-- | Grid column count: explicit, else as many @minColW@ columns as fit in a
-- positive @availW@, else one.
{-# INLINE gridColumnCount #-}
gridColumnCount :: Int -> Float -> Float -> Float -> Int
gridColumnCount :: Int -> Float -> Float -> Float -> Int
gridColumnCount Int
gCols Float
minColW Float
availW Float
gap
  | Int
gCols Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int
gCols
  | Float
minColW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Float
availW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Float
availW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
minColW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap)))
  | Bool
otherwise = Int
1

-- | Height of grid row @r@: its tallest child.
gridRowHeight :: MutablePrimArray RealWorld Float -> Int -> Int -> Int -> IO Float
gridRowHeight :: MutablePrimArray RealWorld Float -> Int -> Int -> Int -> IO Float
gridRowHeight MutablePrimArray RealWorld Float
hArr Int
n Int
cols Int
r = Int -> Float -> IO Float
go Int
0 Float
0
  where
    go :: Int -> Float -> IO Float
go !Int
j !Float
accH
      | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cols = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
accH
      | Bool
otherwise = do
          let k :: Int
k = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j
          if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
            then Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
accH
            else do
              h <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
hArr Int
k
              go (j + 1) (max accH h)

measureGridScratch ::
  SolveEnv ->
  NodeIdx ->
  Int ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO (Float, Float)
measureGridScratch :: SolveEnv
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> IO (Float, Float)
measureGridScratch SolveEnv
env Int
idx Int
gCols Float
minColW Float
innerMaxW Float
innerAvailH Float
gap = do
  n <- NodeArena -> Int -> (Int -> IO (Float, Float)) -> IO Int
loadChildrenScratch (SolveEnv -> NodeArena
seArena SolveEnv
env) Int
idx (SolveEnv -> Bool -> Float -> Float -> Int -> IO (Float, Float)
flowChildSize SolveEnv
env Bool
False Float
innerMaxW Float
innerAvailH)
  if n <= 0
    then pure (0, 0)
    else do
      FlexScratch {fsW = wArr, fsH = hArr} <- readIORef (naScratch (seArena env))
      let cols = Int -> Float -> Float -> Float -> Int
gridColumnCount Int
gCols Float
minColW (if Float
innerMaxW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8 then Float
innerMaxW else Float
0) Float
gap
          numRows = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
cols
          calcRows !Int
r !Float
totalH
            | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numRows = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
totalH
            | Bool
otherwise = do
                rowH <- MutablePrimArray RealWorld Float -> Int -> Int -> Int -> IO Float
gridRowHeight MutablePrimArray RealWorld Float
hArr Int
n Int
cols Int
r
                calcRows (r + 1) (totalH + rowH)
      totalH <- calcRows 0 0
      let contentH = Float
totalH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
numRows Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      contentW <-
        if innerMaxW > 0 && innerMaxW < 1e8
          then pure innerMaxW
          else if minColW > 0
            then pure (fromIntegral cols * minColW + gap * fromIntegral (max 0 (cols - 1)))
            else do
              let getMaxChildW !Int
i !Float
accW
                    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
accW
                    | Bool
otherwise = do
                        w <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
wArr Int
i
                        getMaxChildW (i + 1) (max accW w)
              maxChildW <- getMaxChildW 0 0
              pure (fromIntegral cols * maxChildW + gap * fromIntegral (max 0 (cols - 1)))
      pure (contentW, contentH)

recomputeFitHeightAtWidth :: SolveEnv -> NodeIdx -> Float -> IO Float
recomputeFitHeightAtWidth :: SolveEnv -> Int -> Float -> IO Float
recomputeFitHeightAtWidth SolveEnv
env Int
idx Float
availW = do
  let na :: NodeArena
na = SolveEnv -> NodeArena
seArena SolveEnv
env
  (_, h) <- NodeArena
-> IORef WidthMemo
-> Int
-> Float
-> IO (Float, Float)
-> IO (Float, Float)
memoizeWidth NodeArena
na (NodeArena -> IORef WidthMemo
naFitMemo NodeArena
na) Int
idx Float
availW ((,) Float
0 (Float -> (Float, Float)) -> IO Float -> IO (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SolveEnv -> Int -> Float -> IO Float
recomputeFitHeightAtWidthGo SolveEnv
env Int
idx Float
availW)
  pure h

recomputeFitHeightAtWidthGo :: SolveEnv -> NodeIdx -> Float -> IO Float
recomputeFitHeightAtWidthGo :: SolveEnv -> Int -> Float -> IO Float
recomputeFitHeightAtWidthGo env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
fm, seLookupMeasure :: SolveEnv -> WidgetId -> IO (Maybe CustomMeasureFn)
seLookupMeasure = WidgetId -> IO (Maybe CustomMeasureFn)
lookupMeasure} Int
idx Float
availW = do
  nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
  (minW, minH, maxW, maxH) <- getMinMax na idx
  (wTag, wVal) <- getWidthSizing na idx
  (hTag, _) <- getHeightSizing na idx
  (_, _, _, oldH) <- getRect na idx
  let effW = case SizingTag
wTag of
        SizingTag
SizingPercent -> Float
availW Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
wVal Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100
        SizingTag
SizingFixed -> Float
wVal
        SizingTag
_ -> Float
availW
      effW' = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW Float
effW
  case nt of
    NodeType
NodeText
      | SizingTag
hTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
/= SizingTag
SizingFixed -> do
          isRowChild <- NodeArena -> Int -> IO Bool
parentIsRow NodeArena
na Int
idx
          txt <- getText na idx
          if T.null txt
            then pure (clamp minH maxH 0)
            else do
              TextBox {tbWrapped, tbH, tbLineH} <-
                measureTextNodeAt env idx txt effW' (wrapsNarrower (wTag /= SizingFit && not isRowChild))
              pure (if tbWrapped then clamp minH maxH (max tbLineH tbH) else oldH)
      | Bool
otherwise -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
oldH

    -- A measured drawing, like wrapped text, can be taller when narrower.
    NodeType
NodeDrawing
      | SizingTag
hTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingFit -> do
          wid <- NodeArena -> Int -> IO WidgetId
getWidgetId NodeArena
na Int
idx
          lookupMeasure wid >>= \case
            Just CustomMeasureFn
measure -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH ((Float, Float) -> Float
forall a b. (a, b) -> b
snd (CustomMeasureFn
measure FontMetrics
fm (Float
effW', if Float
maxH Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8 then Float
maxH else Float
1e9))))
            Maybe CustomMeasureFn
Nothing -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
oldH
      | Bool
otherwise -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
oldH

    NodeType
_ | (NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeContainer Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodePanel), SizingTag
hTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
/= SizingTag
SizingFixed -> do
          dir <- NodeArena -> Int -> IO DirTag
getDirection NodeArena
na Int
idx
          if dir == DirRow
            then pure oldH
            else do
              pad <- getPadding na idx
              gap <- getGap na idx
              let innerW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
effW' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padL Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padR Padding
pad)
                  step (FlowAcc Int
count Float
contentH Float
_) Int
ci = do
                    (subWTag, subWVal) <- NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
ci
                    (_, _, subMaxW, _) <- getMinMax na ci
                    let subW = case SizingTag
subWTag of
                          SizingTag
SizingPercent -> Float
innerW Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
subWVal Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100
                          SizingTag
SizingFixed -> Float
subWVal
                          SizingTag
_ -> Float
innerW
                        subW' = if Float
subMaxW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8 then Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
subW Float
subMaxW else Float
subW
                    subH <- recomputeFitHeightAtWidth env ci subW'
                    pure (FlowAcc (count + 1) (contentH + subH) 0)
              FlowAcc count contentH _ <- foldFlowChildrenM na idx step (FlowAcc 0 0 0)
              let totalH =
                    if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
                      then Float
0
                      else Float
contentH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              pure (clamp minH maxH (totalH + padT pad + padB pad))

    NodeType
_ -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
oldH

-- | Load a parent's flow children into the flex scratch in child order, with
-- each child's (width, height) from @sizeOf@. Returns the child count.
{-# INLINE loadChildrenScratch #-}
loadChildrenScratch :: NodeArena -> NodeIdx -> (NodeIdx -> IO (Float, Float)) -> IO Int
loadChildrenScratch :: NodeArena -> Int -> (Int -> IO (Float, Float)) -> IO Int
loadChildrenScratch NodeArena
na Int
parent Int -> IO (Float, Float)
sizeOf = do
  cc <- NodeArena -> Int -> IO Int
getChildCount NodeArena
na Int
parent
  FlexScratch {fsIdx = idxArr, fsW = wArr, fsH = hArr} <- ensureScratchCapacity na cc
  let write !Int
i Int
ci = do
        (w, h) <- Int -> IO (Float, Float)
sizeOf Int
ci
        writePrimArray idxArr i ci
        writePrimArray wArr i w
        writePrimArray hArr i h
        pure (i + 1)
  n <- foldFlowChildrenM na parent write 0
  reverseScratchTriple idxArr wArr hArr 0 (n - 1)
  pure n

-- | Scratch size of a flow child: its measured box, with percent sizing
-- resolved against the parent's inner box. With @refit@, a fit-height child
-- that the parent narrows (grow or percent width, or wider than @availW@) is
-- re-measured at the assigned width.
flowChildSize :: SolveEnv -> Bool -> Float -> Float -> NodeIdx -> IO (Float, Float)
flowChildSize :: SolveEnv -> Bool -> Float -> Float -> Int -> IO (Float, Float)
flowChildSize SolveEnv
env Bool
refit Float
availW Float
availH Int
ci = do
  let a :: NodeArenaArrays
a = SolveEnv -> NodeArenaArrays
seArrays SolveEnv
env
  w <- NodeArenaArrays -> Int -> Int -> IO Float
readGeom NodeArenaArrays
a Int
ci Int
geomW
  h <- readGeom a ci geomH
  wTag <- readTagEnum a ci tagWSizing
  wVal <- readStyle a ci styleWVal
  hTag <- readTagEnum a ci tagHSizing
  hVal <- readStyle a ci styleHVal
  minW <- readStyle a ci styleMinW
  minH <- readStyle a ci styleMinH
  maxW <- readStyle a ci styleMaxW
  maxH <- readStyle a ci styleMaxH
  let w' =
        case SizingTag
wTag of
          SizingTag
SizingPercent -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW (Float
availW Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
wVal Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100)
          SizingTag
_ -> Float
w
  h' <-
    if refit && hTag /= SizingFixed && hTag /= SizingPercent && (wTag == SizingGrow || wTag == SizingPercent || availW < w)
      then recomputeFitHeightAtWidth env ci (if wTag == SizingPercent then w' else availW)
      else pure $
        case hTag of
          SizingTag
SizingPercent -> Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH (Float
availH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
hVal Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100)
          SizingTag
_ -> Float
h
  pure (w', h')

positionNodeA ::
  SolveEnv ->
  Int ->
  NodeIdx ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
positionNodeA :: SolveEnv -> Int -> Int -> Float -> Float -> Float -> Float -> IO ()
positionNodeA env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seArrays :: SolveEnv -> NodeArenaArrays
seArrays = NodeArenaArrays
a, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
fm, seLookupMeasure :: SolveEnv -> WidgetId -> IO (Maybe CustomMeasureFn)
seLookupMeasure = WidgetId -> IO (Maybe CustomMeasureFn)
lookupMeasure} Int
depth Int
idx Float
x Float
y Float
availW Float
availH = do
  minW <- NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
styleMinW
  minH <- readStyle a idx styleMinH
  maxW <- readStyle a idx styleMaxW
  maxH <- readStyle a idx styleMaxH
  wTag <- readTagEnum a idx tagWSizing
  wVal <- readStyle a idx styleWVal
  hTag <- readTagEnum a idx tagHSizing
  hVal <- readStyle a idx styleHVal
  intrinsicW <- readGeom a idx geomW
  intrinsicH <- readGeom a idx geomH
  nt <- readTagEnum a idx tagNodeType
  let w = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW (SizingTag -> Float -> Float -> Float -> Float -> Float -> Float
resolveSize SizingTag
wTag Float
wVal Float
intrinsicW Float
availW Float
minW Float
maxW)
  isRowChild <- parentIsRow na idx
  h <-
    if nt == NodeText && hTag /= SizingFixed && not isRowChild
      then do
        txt <- getText na idx
        if T.null txt
          then pure (clamp minH maxH 0)
          else do
            TextBox {tbWrapped, tbH, tbLineH} <-
              measureTextNodeAt env idx txt w (wrapsNarrower (wTag /= SizingFit))
            pure . clamp minH maxH $
              if tbWrapped
                then max tbLineH tbH
                else resolveSize hTag hVal intrinsicH availH minH maxH
      else
        if (nt == NodeContainer || nt == NodePanel) && hTag == SizingFit
          then pure (clamp minH maxH (max intrinsicH availH))
          else
            if nt == NodeDrawing && hTag == SizingFit && w /= intrinsicW
              then do
                -- A measured drawing laid out at another width than it was
                -- measured at takes its height at the width it got.
                wid <- getWidgetId na idx
                lookupMeasure wid >>= \case
                  Just CustomMeasureFn
measure -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH ((Float, Float) -> Float
forall a b. (a, b) -> b
snd (CustomMeasureFn
measure FontMetrics
fm (Float
w, if Float
maxH Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e8 then Float
maxH else Float
1e9))))
                  Maybe CustomMeasureFn
Nothing -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH (SizingTag -> Float -> Float -> Float -> Float -> Float -> Float
resolveSize SizingTag
hTag Float
hVal Float
intrinsicH Float
availH Float
minH Float
maxH))
              else pure (clamp minH maxH (resolveSize hTag hVal intrinsicH availH minH maxH))
  setRect na idx x y w h
  when (isContainerNode nt) $ do
    (pad, gap, dir) <- containerFlow a idx
    if isScrollNode nt
      then positionScrollChildren env depth idx dir gap pad x y w h
      else positionChildren env depth idx dir gap pad x y w h
  when (hTag == SizingFit && isContainerNode nt && not (isScrollNode nt)) $
    adjustFitHeight na fm idx minH maxH x y w

-- | A container's resolved padding and gap, and its direction.
{-# INLINE containerFlow #-}
containerFlow :: NodeArenaArrays -> NodeIdx -> IO (Padding, Float, DirTag)
containerFlow :: NodeArenaArrays -> Int -> IO (Padding, Float, DirTag)
containerFlow NodeArenaArrays
a Int
idx = do
  pad <- Float -> Float -> Float -> Float -> Padding
Padding (Float -> Float -> Float -> Float -> Padding)
-> IO Float -> IO (Float -> Float -> Float -> Padding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArenaArrays -> Int -> Int -> IO Float
readStyle NodeArenaArrays
a Int
idx Int
stylePadL IO (Float -> Float -> Float -> Padding)
-> IO Float -> IO (Float -> Float -> Padding)
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
stylePadR IO (Float -> Float -> Padding) -> IO Float -> IO (Float -> Padding)
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
stylePadT IO (Float -> Padding) -> IO Float -> IO Padding
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
stylePadB
  gap <- readStyle a idx styleGap
  dir <- readTagEnum a idx tagDirection
  pure (pad, gap, dir)

adjustFitHeight :: NodeArena -> FontMetrics -> NodeIdx -> Float -> Float -> Float -> Float -> Float -> IO ()
adjustFitHeight :: NodeArena
-> FontMetrics
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
adjustFitHeight NodeArena
na FontMetrics
fm Int
idx Float
minH Float
maxH Float
x Float
y Float
w = do
  fc <- NodeArena -> Int -> IO Int
getFirstChild NodeArena
na Int
idx
  when (fc >= 0) $ do
    pad <- getPadding na idx
    let step Float
maxB Int
ci = do
          (_, subY, _, subH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect NodeArena
na Int
ci
          pure (max maxB (subY + subH))
        -- Rounding a child's origin to the nearest device pixel can put its
        -- bottom up to half a pixel below where measurement did. That is not
        -- content outgrowing the measurement: growing for it adds half a
        -- pixel at every nested content-sized level, until a dialog sized to
        -- its content overflows its own scroll viewport. The small epsilon
        -- absorbs float error in the rounding.
        s = FontMetrics -> Float
fmSnapScale FontMetrics
fm
        snapSlack = if Float
s Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
0.5 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1.0e-3 else Float
0
    maxB <- foldFlowChildrenM na idx step y
    let fitH = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH (Float
maxB Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padB Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y)
    (_, _, _, curH) <- getRect na idx
    when (fitH > curH + snapSlack) $
      setRect na idx x y w fitH

positionScrollChildren ::
  SolveEnv ->
  Int ->
  NodeIdx ->
  DirTag ->
  Float ->
  Padding ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
positionScrollChildren :: SolveEnv
-> Int
-> Int
-> DirTag
-> Float
-> Padding
-> Float
-> Float
-> Float
-> Float
-> IO ()
positionScrollChildren env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na} Int
depth Int
idx DirTag
dir Float
gap Padding
pad Float
px Float
py Float
pw Float
ph = do
  si <- NodeArena -> Int -> IO Int
getStyleIdx NodeArena
na Int
idx
  contentSize <- getNodeValue na idx
  slot <- scrollBarSlotOf na idx
  let cx = Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padL Padding
pad
      cy = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padT Padding
pad
      innerW = Float
pw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padL Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padR Padding
pad
      innerH = Float
ph Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padT Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padB Padding
pad
      cfg = Int -> ScrollConfig
decodeScrollConfig Int
si
  if isScrollStyle2D si
    then do
      contentW <- getScrollContentW na idx
      let (gutterW, gutterH) = scrollGutters2D slot cfg pad contentW contentSize innerW innerH
          viewW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
innerW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gutterW)
          viewH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
innerH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gutterH)
          -- Keep measured content. Shrinking to the clip wraps table columns.
          layoutW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
contentW Float
viewW
          layoutH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
contentSize Float
viewH
      -- cx/cy and the layout box are already inside the padding.
      positionChildren env depth idx DirColumn gap (Padding 0 0 0 0) cx cy layoutW layoutH
    else do
      let gutterCol = ScrollPolicy -> ScrollBarSlot -> Float -> Float -> Float -> Float
scrollAxisGutter (ScrollConfig -> ScrollPolicy
scrollPolicyY ScrollConfig
cfg) ScrollBarSlot
slot (Padding -> Float
padR Padding
pad) Float
contentSize Float
innerH
          gutterRow = ScrollPolicy -> ScrollBarSlot -> Float -> Float -> Float -> Float
scrollAxisGutter (ScrollConfig -> ScrollPolicy
scrollPolicyX ScrollConfig
cfg) ScrollBarSlot
slot (Padding -> Float
padB Padding
pad) Float
contentSize Float
innerW
      case dir of
        DirTag
DirRow -> do
          (wTag, _) <- NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
idx
          let rowMain =
                if SizingTag
wTag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingGrow
                  then Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
contentSize (Float
innerW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gutterRow)
                  else Float
contentSize
          positionRowFromParent env depth idx gap cx cy rowMain (innerH - gutterRow)
        DirTag
DirColumn -> SolveEnv
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
positionColumnScroll SolveEnv
env Int
depth Int
idx Float
gap Float
cx Float
cy (Float
innerW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gutterCol) Float
innerH Float
contentSize
  fc <- getFirstChild na idx
  when (fc >= 0) $ do
    let step (FlowAcc Int
count Float
maxB Float
maxR) Int
ci = do
          (subX, subY, subW, subH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect NodeArena
na Int
ci
          pure (FlowAcc (count + 1) (max maxB (subY + subH)) (max maxR (subX + subW)))
    FlowAcc _ maxB maxR <- foldFlowChildrenM na idx step (FlowAcc 0 cy cx)
    -- Content size is measured from the content origin (px+padL, py+padT) so
    -- it compares against the padded viewport (innerW/innerH) on the same
    -- scale. Measuring from the padding-box origin double-counts the leading
    -- padding and makes a child that exactly fills the viewport look
    -- padX/padY bigger, surfacing a phantom scrollbar on padded scrollers.
    -- The trailing padding is excluded here too (so it cannot
    -- surface a bar by itself); scrollAxisRange adds it back into the
    -- reachable range once an axis genuinely overflows, so scrolling to the
    -- end still reveals it.
    let actualContentH = Float
maxB Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padT Padding
pad
        actualContentW = Float
maxR Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padL Padding
pad
    if isScrollStyle2D si
      then do
        oldH <- getNodeValue na idx
        oldW <- getScrollContentW na idx
        setNodeValue na idx (max oldH actualContentH)
        setScrollContentW na idx (max oldW actualContentW)
      else do
        oldVal <- getNodeValue na idx
        let actual = case DirTag
dir of DirTag
DirColumn -> Float
actualContentH; DirTag
DirRow -> Float
actualContentW
        setNodeValue na idx (max oldVal actual)

-- | Where a scroll container's bar sits, as measurement stored it. Text
-- areas and other nodes read 'ScrollBarList'.
{-# INLINE scrollBarSlotOf #-}
scrollBarSlotOf :: NodeArena -> NodeIdx -> IO ScrollBarSlot
scrollBarSlotOf :: NodeArena -> Int -> IO ScrollBarSlot
scrollBarSlotOf NodeArena
na Int
idx = NodeArena -> IO NodeArenaArrays
arenaArrays NodeArena
na IO NodeArenaArrays
-> (NodeArenaArrays -> IO ScrollBarSlot) -> IO ScrollBarSlot
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 ScrollBarSlot
forall e. Enum e => NodeArenaArrays -> Int -> Int -> IO e
readTagEnum NodeArenaArrays
a Int
idx Int
tagScrollBarSlot

hasPanelAncestor :: NodeArena -> NodeIdx -> IO Bool
hasPanelAncestor :: NodeArena -> Int -> IO Bool
hasPanelAncestor NodeArena
na = Int -> IO Bool
go
  where
    go :: Int -> IO Bool
go Int
p
      | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      | Bool
otherwise = do
          nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
p
          case nt of
            NodeType
NodePanel -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            NodeType
NodeWindow -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            NodeType
NodeModal -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            NodeType
NodePopup -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            NodeType
_ -> NodeArena -> Int -> IO Int
getParent NodeArena
na Int
p IO Int -> (Int -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO Bool
go

positionColumnScroll ::
  SolveEnv ->
  Int ->
  NodeIdx ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
positionColumnScroll :: SolveEnv
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
positionColumnScroll env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na} Int
depth Int
parent Float
gap Float
cx Float
cy Float
innerW Float
innerH Float
contentSize = do
  n <- NodeArena -> Int -> (Int -> IO (Float, Float)) -> IO Int
loadChildrenScratch (SolveEnv -> NodeArena
seArena SolveEnv
env) Int
parent (SolveEnv -> Bool -> Float -> Float -> Int -> IO (Float, Float)
flowChildSize SolveEnv
env Bool
True Float
innerW Float
innerH)
  withAxisSnaps na depth n contentSize (gap * fromIntegral (max 0 (n - 1))) False $ \MutablePrimArray RealWorld Int
idxSnap MutablePrimArray RealWorld Float
outSnap -> do
    let go :: Int -> Float -> IO ()
go !Int
i !Float
curY
          | 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
              ci <- 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
idxSnap Int
i
              fh <- readPrimArray outSnap i
              nt <- getNodeType na ci
              fx <- columnChildX na ci cx innerW
              let cw = Float
innerW
                  visibleSlice = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
innerH Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
curY Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy))
                  nodeH =
                    if NodeType -> Bool
isScrollNode NodeType
nt
                      then Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
fh Float
visibleSlice
                      else Float
fh
              positionNodeA env (depth + 1) ci fx curY cw nodeH
              (_, _, _, placedH) <- getRect na ci
              go (i + 1) (curY + placedH + gap)
    Int -> Float -> IO ()
go Int
0 Float
cy

-- | Left edge of column child @ci@ in a column of width @cw@ at @cx@. Grow and
-- percent children already take the full width; alignment is for content
-- narrower than the column, not for shifting a full-width box past it.
{-# INLINE columnChildX #-}
columnChildX :: NodeArena -> NodeIdx -> Float -> Float -> IO Float
columnChildX :: NodeArena -> Int -> Float -> Float -> IO Float
columnChildX NodeArena
na Int
ci Float
cx Float
cw = do
  (wTag, _) <- NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
ci
  if wTag == SizingGrow || wTag == SizingPercent
    then pure cx
    else do
      (_, _, iw, _) <- getRect na ci
      ax <- getAlignX na ci
      pure $! alignX ax cx cw iw

{-# INLINE resolveSize #-}
resolveSize :: SizingTag -> Float -> Float -> Float -> Float -> Float -> Float
resolveSize :: SizingTag -> Float -> Float -> Float -> Float -> Float -> Float
resolveSize SizingTag
SizingFixed Float
v Float
_ Float
_ Float
_ Float
_ = Float
v
resolveSize SizingTag
SizingFit Float
_ Float
intrinsic Float
avail Float
minS Float
maxS = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minS Float
maxS (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
intrinsic Float
avail)
resolveSize SizingTag
SizingShrink Float
_ Float
intrinsic Float
avail Float
minS Float
maxS = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minS Float
maxS (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
intrinsic Float
avail)
resolveSize SizingTag
SizingGrow Float
_ Float
_ Float
avail Float
_ Float
maxS = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
avail Float
maxS
resolveSize SizingTag
SizingPercent Float
_ Float
_ Float
avail Float
_ Float
maxS = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
avail Float
maxS

positionChildren ::
  SolveEnv ->
  Int ->
  NodeIdx ->
  DirTag ->
  Float ->
  Padding ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
positionChildren :: SolveEnv
-> Int
-> Int
-> DirTag
-> Float
-> Padding
-> Float
-> Float
-> Float
-> Float
-> IO ()
positionChildren env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na} Int
depth Int
idx DirTag
dir Float
gap Padding
pad Float
px Float
py Float
pw Float
ph = do
  nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
  gCols <- getGridCols na idx
  minColW <- getGridMinColW na idx
  let chrome = NodeType -> DirTag -> Bool
isChromeColumn NodeType
nt DirTag
dir
      cx = Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padL Padding
pad
      cy = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padT Padding
pad
      cw = Float
pw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padL Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padR Padding
pad
      ch = Float
ph Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padT Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padB Padding
pad
  if gCols > 0 || minColW > 0
    then positionGrid env depth idx gCols minColW gap cx cy cw ch
    else case dir of
      DirTag
DirRow -> SolveEnv
-> Int -> Int -> Float -> Float -> Float -> Float -> Float -> IO ()
positionRowFromParent SolveEnv
env Int
depth Int
idx Float
gap Float
cx Float
cy Float
cw Float
ch
      DirTag
DirColumn -> SolveEnv
-> Int
-> Int
-> Float
-> Bool
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
positionColumnFromParent SolveEnv
env Int
depth Int
idx Float
gap Bool
chrome Float
px Float
pw Float
cx Float
cy Float
cw Float
ch

childRowCrossSize :: NodeArena -> NodeIdx -> Float -> IO Float
childRowCrossSize :: NodeArena -> Int -> Float -> IO Float
childRowCrossSize NodeArena
na Int
ci Float
availCross = do
  (hTag, hVal) <- NodeArena -> Int -> IO (SizingTag, Float)
getHeightSizing NodeArena
na Int
ci
  (_, _, _, intrinsic) <- getRect na ci
  (_, minH, _, maxH) <- getMinMax na ci
  let resolved = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH (SizingTag -> Float -> Float -> Float -> Float -> Float -> Float
resolveSize SizingTag
hTag Float
hVal Float
intrinsic Float
availCross Float
minH Float
maxH)
  case hTag of
    SizingTag
SizingFixed -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH Float
hVal)
    SizingTag
SizingGrow -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
resolved
    SizingTag
SizingPercent -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
resolved
    SizingTag
_ ->
      -- Fit/Shrink keep the measured box. Do not use the wrap-line
      -- or row slot as availH: that stretches every child when leftover
      -- leaks into scratch `fh`.
      Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minH Float
intrinsic)

-- Column leftover must not change Fixed step height.
columnChildHeight :: NodeArena -> NodeIdx -> Float -> IO Float
columnChildHeight :: NodeArena -> Int -> Float -> IO Float
columnChildHeight NodeArena
na Int
ci Float
scratchH = do
  (hTag, _) <- NodeArena -> Int -> IO (SizingTag, Float)
getHeightSizing NodeArena
na Int
ci
  case hTag of
    SizingTag
SizingFixed -> do
      (_, minH, _, maxH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getMinMax NodeArena
na Int
ci
      (_, _, _, ih) <- getRect na ci
      pure (clamp minH maxH ih)
    SizingTag
_ -> do
      (_, minH, _, maxH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getMinMax NodeArena
na Int
ci
      pure (clamp minH maxH scratchH)

{-# INLINE withAxisSnaps #-}
withAxisSnaps ::
  NodeArena ->
  Int ->
  Int ->
  Float ->
  Float ->
  Bool ->
  (MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> IO a) ->
  IO a
withAxisSnaps :: forall a.
NodeArena
-> Int
-> Int
-> Float
-> Float
-> Bool
-> (MutablePrimArray RealWorld Int
    -> MutablePrimArray RealWorld Float -> IO a)
-> IO a
withAxisSnaps NodeArena
na Int
depth Int
n Float
availMain Float
gapSum Bool
horizontal MutablePrimArray RealWorld Int
-> MutablePrimArray RealWorld Float -> IO a
act = do
  NodeArena -> Int -> Float -> Float -> Bool -> IO ()
distributeScratch NodeArena
na Int
n Float
availMain Float
gapSum Bool
horizontal
  FlexScratch {fsIdx = idxArr, fsOutW = outW, fsOutH = outH} <- IORef FlexScratch -> IO FlexScratch
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef FlexScratch
naScratch NodeArena
na)
  let outArr = if Bool
horizontal then MutablePrimArray RealWorld Float
outW else MutablePrimArray RealWorld Float
outH
  AxisSnapshot idxSnap outSnap <- ensureAxisSnapshot na depth n
  copyMutablePrimArray idxSnap 0 idxArr 0 n
  copyMutablePrimArray outSnap 0 outArr 0 n
  act idxSnap outSnap

-- | Like 'withAxisSnaps' but snapshots the unscaled child cross sizes instead
-- of the distributed main-axis result. Grids compute rows from the measured
-- child heights, so freezing them lets the recursion reuse the working scratch.
withGridScratch :: NodeArena -> Int -> Int -> (MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> IO a) -> IO a
withGridScratch :: forall a.
NodeArena
-> Int
-> Int
-> (MutablePrimArray RealWorld Int
    -> MutablePrimArray RealWorld Float -> IO a)
-> IO a
withGridScratch NodeArena
na Int
depth Int
n MutablePrimArray RealWorld Int
-> MutablePrimArray RealWorld Float -> IO a
act = do
  FlexScratch {fsIdx = idxArr, fsH = hArr} <- IORef FlexScratch -> IO FlexScratch
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef FlexScratch
naScratch NodeArena
na)
  AxisSnapshot idxSnap crossSnap <- ensureAxisSnapshot na depth n
  copyMutablePrimArray idxSnap 0 idxArr 0 n
  copyMutablePrimArray crossSnap 0 hArr 0 n
  act idxSnap crossSnap

positionRowFromParent ::
  SolveEnv ->
  Int ->
  NodeIdx ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
positionRowFromParent :: SolveEnv
-> Int -> Int -> Float -> Float -> Float -> Float -> Float -> IO ()
positionRowFromParent env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
fm} Int
depth Int
parent Float
gap Float
cx Float
cy Float
cw Float
ch = do
  n <- NodeArena -> Int -> (Int -> IO (Float, Float)) -> IO Int
loadChildrenScratch (SolveEnv -> NodeArena
seArena SolveEnv
env) Int
parent (SolveEnv -> Bool -> Float -> Float -> Int -> IO (Float, Float)
flowChildSize SolveEnv
env Bool
False Float
cw Float
ch)
  withAxisSnaps na depth n cw (gap * fromIntegral (max 0 (n - 1))) True $ \MutablePrimArray RealWorld Int
idxSnap MutablePrimArray RealWorld Float
outSnap -> do
    -- The shared baseline sits as low as the deepest one among the children
    -- aligned on it, so the child with the tallest ascent stays at the top.
    let goBase :: Int -> Float -> IO Float
goBase !Int
i !Float
acc
          | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
acc
          | Bool
otherwise = do
              ci <- 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
idxSnap Int
i
              ay <- getAlignY na ci
              if ay /= AlignBaseline
                then goBase (i + 1) acc
                else do
                  b <- childRowCrossSize na ci ch >>= childBaseline env ci
                  goBase (i + 1) (max acc b)
    rowBase <- Int -> Float -> IO Float
goBase Int
0 Float
0
    let goRow !Int
i !Float
cur !Float
prev
          | 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
              ci <- 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
idxSnap Int
i
              fw <- readPrimArray outSnap i
              let x = Float -> Float -> Float -> Float
snappedOrigin (FontMetrics -> Float
fmSnapScale FontMetrics
fm) Float
cur Float
prev
              -- Fit/fixed children keep content height. Only Grow/Percent eat `ch`.
              crossH <- childRowCrossSize na ci ch
              ay <- getAlignY na ci
              fy <-
                if ay == AlignBaseline
                  then (\Float
b -> Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rowBase Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
b) <$> childBaseline env ci crossH
                  else pure (alignY ay cy ch crossH)
              positionNodeA env (depth + 1) ci x fy fw crossH
              -- A grow child that its max width stopped short of its share
              -- hands the rest to the siblings after it instead of leaving a
              -- hole.
              placedW <- readGeom (seArrays env) ci geomW
              goRow (i + 1) (cur + min fw placedW + gap) x
    goRow 0 cx (-1 / 0)

-- | Placed origin of the flow child at raw cursor @cur@ when the previous
-- sibling was placed at @prev@ (negative infinity for the first child), on a
-- device grid of scale @s@.
--
-- Flex positions stay exact: the cursor accumulates in raw floats and only the
-- placed origin snaps, never the running sum. Rounding the cumulative cursor
-- re-compounds error every child (1.667 -> 2.0 -> ...) so a shrink row
-- overruns its fixed width. The one-pixel floor past @prev@ keeps two
-- siblings from quantizing to the same origin while resisting that drift.
{-# INLINE snappedOrigin #-}
snappedOrigin :: Float -> Float -> Float -> Float
snappedOrigin :: Float -> Float -> Float -> Float
snappedOrigin Float
s Float
cur Float
prev
  | Float
s Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float -> Float -> Float
onGrid Float
s Float
cur) (Float
prev Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
s)
  | Bool
otherwise = Float
cur

positionGrid ::
  SolveEnv ->
  Int ->
  NodeIdx ->
  Int ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
positionGrid :: SolveEnv
-> Int
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
positionGrid env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na} Int
depth Int
parent Int
gCols Float
minColW Float
gap Float
cx Float
cy Float
cw Float
ch = do
  n <- NodeArena -> Int -> (Int -> IO (Float, Float)) -> IO Int
loadChildrenScratch (SolveEnv -> NodeArena
seArena SolveEnv
env) Int
parent (SolveEnv -> Bool -> Float -> Float -> Int -> IO (Float, Float)
flowChildSize SolveEnv
env Bool
False Float
cw Float
ch)
  when (n > 0) $ do
    let cols = Int -> Float -> Float -> Float -> Int
gridColumnCount Int
gCols Float
minColW Float
cw Float
gap
        colW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 ((Float
cw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gap Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cols)
        numRows = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
cols
    -- Freeze child indices and their measured cross sizes before recursing.
    -- Children reuse the working scratch while this grid iterates rows and
    -- columns, so the live arrays would be clobbered by the first child.
    withGridScratch na depth n $ \MutablePrimArray RealWorld Int
idxArr MutablePrimArray RealWorld Float
hArr ->
      do
        let goRows :: Int -> Float -> IO ()
goRows !Int
r !Float
curY
              | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numRows = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              | Bool
otherwise = do
                  rowH <- MutablePrimArray RealWorld Float -> Int -> Int -> Int -> IO Float
gridRowHeight MutablePrimArray RealWorld Float
hArr Int
n Int
cols Int
r
                  let goCols !Int
j
                        | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cols = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        | Bool
otherwise = do
                            let k :: Int
k = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j
                            if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
                              then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                              else do
                                ci <- 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
idxArr Int
k
                                (minW, minH, maxW, maxH) <- getMinMax na ci
                                (wTag, wVal) <- getWidthSizing na ci
                                (hTag, hVal) <- getHeightSizing na ci
                                (_, _, iw, ih) <- getRect na ci
                                let childW = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW Float
maxW (SizingTag -> Float -> Float -> Float -> Float -> Float -> Float
resolveSize SizingTag
wTag Float
wVal Float
iw Float
colW Float
minW Float
maxW)
                                    childH = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH Float
maxH (SizingTag -> Float -> Float -> Float -> Float -> Float -> Float
resolveSize SizingTag
hTag Float
hVal Float
ih Float
rowH Float
minH Float
maxH)
                                    itemX = Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
colW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap)
                                ax <- getAlignX na ci
                                ay <- getAlignY na ci
                                let fx = AlignX -> Float -> Float -> Float -> Float
alignX AlignX
ax Float
itemX Float
colW Float
childW
                                    fy = AlignY -> Float -> Float -> Float -> Float
alignY AlignY
ay Float
curY Float
rowH Float
childH
                                positionNodeA env (depth + 1) ci fx fy colW rowH
                                goCols (j + 1)
                  goCols 0
                  goRows (r + 1) (curY + rowH + gap)
        Int -> Float -> IO ()
goRows Int
0 Float
cy

positionColumnFromParent ::
  SolveEnv ->
  Int ->
  NodeIdx ->
  Float ->
  Bool ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
positionColumnFromParent :: SolveEnv
-> Int
-> Int
-> Float
-> Bool
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
positionColumnFromParent env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
fm} Int
depth Int
parent Float
gap Bool
chrome Float
px Float
pw Float
cx Float
cy Float
cw Float
ch = do
  n <- NodeArena -> Int -> (Int -> IO (Float, Float)) -> IO Int
loadChildrenScratch (SolveEnv -> NodeArena
seArena SolveEnv
env) Int
parent (SolveEnv -> Bool -> Float -> Float -> Int -> IO (Float, Float)
flowChildSize SolveEnv
env Bool
True Float
cw Float
ch)
  gapSum <- columnGapSumScratch na chrome n gap
  withAxisSnaps na depth n ch gapSum False $ \MutablePrimArray RealWorld Int
idxSnap MutablePrimArray RealWorld Float
outSnap -> do
    let go :: Int -> Float -> Float -> IO ()
go !Int
i !Float
cur !Float
prev
          | 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
              ci <- 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
idxSnap Int
i
              fh <- readPrimArray outSnap i
              let y = Float -> Float -> Float -> Float
snappedOrigin (FontMetrics -> Float
fmSnapScale FontMetrics
fm) Float
cur Float
prev
              nt <- getNodeType na ci
              (fx, nodeW) <-
                if chrome && nt == NodeSeparator
                  then pure (px, pw)
                  else (,cw) <$> columnChildX na ci cx cw
              childH <- columnChildHeight na ci fh
              positionNodeA env (depth + 1) ci fx y nodeW childH
              (_, _, _, placedH) <- getRect na ci
              gapAfter <-
                if i + 1 >= n
                  then pure 0
                  else do
                    nextCi <- readPrimArray idxSnap (i + 1)
                    pairColumnGap na chrome nextCi gap
              go (i + 1) (cur + placedH + gapAfter) y
    Int -> Float -> Float -> IO ()
go Int
0 Float
cy (-Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0)


{-# INLINE reverseScratchTriple #-}
reverseScratchTriple ::
  MutablePrimArray RealWorld Int ->
  MutablePrimArray RealWorld Float ->
  MutablePrimArray RealWorld Float ->
  Int ->
  Int ->
  IO ()
reverseScratchTriple :: MutablePrimArray RealWorld Int
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Int
-> Int
-> IO ()
reverseScratchTriple MutablePrimArray RealWorld Int
idxArr MutablePrimArray RealWorld Float
mainArr MutablePrimArray RealWorld Float
crossArr Int
lo Int
hi = do
  let go :: Int -> Int -> IO ()
go !Int
a !Int
b
        | Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
b = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = do
            MutablePrimArray RealWorld Int -> Int -> Int -> IO ()
forall a.
Prim a =>
MutablePrimArray RealWorld a -> Int -> Int -> IO ()
swapPrim MutablePrimArray RealWorld Int
idxArr Int
a Int
b
            MutablePrimArray RealWorld Float -> Int -> Int -> IO ()
forall a.
Prim a =>
MutablePrimArray RealWorld a -> Int -> Int -> IO ()
swapPrim MutablePrimArray RealWorld Float
mainArr Int
a Int
b
            MutablePrimArray RealWorld Float -> Int -> Int -> IO ()
forall a.
Prim a =>
MutablePrimArray RealWorld a -> Int -> Int -> IO ()
swapPrim MutablePrimArray RealWorld Float
crossArr Int
a Int
b
            Int -> Int -> IO ()
go (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Int -> Int -> IO ()
go Int
lo Int
hi

{-# INLINE swapPrim #-}
swapPrim :: (Prim a) => MutablePrimArray RealWorld a -> Int -> Int -> IO ()
swapPrim :: forall a.
Prim a =>
MutablePrimArray RealWorld a -> Int -> Int -> IO ()
swapPrim MutablePrimArray RealWorld a
arr Int
a Int
b = do
  x <- 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
arr Int
a
  y <- readPrimArray arr b
  writePrimArray arr a y
  writePrimArray arr b x
{-# SPECIALIZE swapPrim :: MutablePrimArray RealWorld Int -> Int -> Int -> IO () #-}
{-# SPECIALIZE swapPrim :: MutablePrimArray RealWorld Float -> Int -> Int -> IO () #-}

columnGapSumScratch :: NodeArena -> Bool -> Int -> Float -> IO Float
columnGapSumScratch :: NodeArena -> Bool -> Int -> Float -> IO Float
columnGapSumScratch NodeArena
_ Bool
False Int
_ Float
_ = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0
columnGapSumScratch NodeArena
_ Bool
True Int
n Float
_
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0
columnGapSumScratch NodeArena
na Bool
True Int
n Float
gap = do
  FlexScratch {fsIdx = idxArr} <- IORef FlexScratch -> IO FlexScratch
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef FlexScratch
naScratch NodeArena
na)
  let go !Int
i !Float
acc
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
acc
        | Bool
otherwise = do
            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
idxArr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            g <- pairColumnGap na True b gap
            go (i + 1) (acc + g)
  go 0 0

-- | Resolve the main-axis sizes of the first @n@ scratch children.
distributeScratch :: NodeArena -> Int -> Float -> Float -> Bool -> IO ()
distributeScratch :: NodeArena -> Int -> Float -> Float -> Bool -> IO ()
distributeScratch NodeArena
na Int
n Float
avail Float
gapSum Bool
horizontal = do
  FlexScratch {fsIdx = idxArr, fsW = wArr, fsH = hArr, fsOutW = outW, fsOutH = outH} <- IORef FlexScratch -> IO FlexScratch
forall a. IORef a -> IO a
readIORef (NodeArena -> IORef FlexScratch
naScratch NodeArena
na)
  total <- sumScratchAxis wArr hArr horizontal 0 n 0
  let slack = Float
avail Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
total Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gapSum)
  if slack > 0.001
    then do
      growTotal <- sumFactors growFactor na idxArr horizontal n
      if growTotal <= 0
        then copyScratchRange wArr hArr outW outH 0 n
        else do
          -- Grow children share the free space by factor, but no child is
          -- squeezed below its content size (a min-content floor, like CSS
          -- flex with min-width:auto): two fillW columns come out equal unless
          -- one column's content needs more, and that one then takes exactly
          -- what it needs while the rest re-share what is left.
          --
          -- Grow factors live in the cross output (0 once a child is not or
          -- no longer growing): withAxisSnaps only consumes the main-axis
          -- array, so it is free scratch here and is restored to real cross
          -- sizes before returning. mainArr keeps the exact content size
          -- throughout; no arithmetic on markers.
          let mainArr = if Bool
horizontal then MutablePrimArray RealWorld Float
outW else MutablePrimArray RealWorld Float
outH
              crossArr = if Bool
horizontal then MutablePrimArray RealWorld Float
outH else MutablePrimArray RealWorld Float
outW
          markGrowFlags na idxArr wArr hArr mainArr crossArr horizontal 0 n
          (free, gfSum) <- settleGrow mainArr crossArr avail gapSum n (n + 1)
          applyGrowShares wArr hArr mainArr crossArr horizontal free gfSum 0 n
    else
      if slack < -0.001
        then do
          shrinkTotal <- sumFactors shrinkFactor na idxArr horizontal n
          if shrinkTotal <= 0
            then copyScratchRange wArr hArr outW outH 0 n
            else applyShrink na idxArr wArr hArr outW outH horizontal (negate slack) shrinkTotal 0 n
        else copyScratchRange wArr hArr outW outH 0 n

-- | @out[i] = (w[i], h[i])@ for the range.
copyScratchRange :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Int -> Int -> IO ()
{-# INLINE copyScratchRange #-}
copyScratchRange :: MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Int
-> Int
-> IO ()
copyScratchRange MutablePrimArray RealWorld Float
wArr MutablePrimArray RealWorld Float
hArr MutablePrimArray RealWorld Float
outW MutablePrimArray RealWorld Float
outH !Int
i !Int
end
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = do
      w <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
wArr Int
i
      h <- readPrimArray hArr i
      writePrimArray outW i w
      writePrimArray outH i h
      copyScratchRange wArr hArr outW outH (i + 1) end

{-# INLINE sumScratchAxis #-}
sumScratchAxis :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Int -> Int -> Float -> IO Float
sumScratchAxis :: MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Bool
-> Int
-> Int
-> Float
-> IO Float
sumScratchAxis MutablePrimArray RealWorld Float
wArr MutablePrimArray RealWorld Float
hArr Bool
horizontal !Int
i !Int
end !Float
acc
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
acc
  | Bool
otherwise = do
      v <- if Bool
horizontal then MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
wArr Int
i else MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
hArr Int
i
      sumScratchAxis wArr hArr horizontal (i + 1) end (acc + v)

-- | Sizing along the main axis: width when @horizontal@, else height.
{-# INLINE getAxisSizing #-}
getAxisSizing :: NodeArena -> NodeIdx -> Bool -> IO (SizingTag, Float)
getAxisSizing :: NodeArena -> Int -> Bool -> IO (SizingTag, Float)
getAxisSizing NodeArena
na Int
idx Bool
horizontal =
  if Bool
horizontal then NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
idx else NodeArena -> Int -> IO (SizingTag, Float)
getHeightSizing NodeArena
na Int
idx

-- | Sum a sizing-derived flex factor over the first @n@ scratch children.
{-# INLINE sumFactors #-}
sumFactors :: (SizingTag -> Float -> Float) -> NodeArena -> MutablePrimArray RealWorld Int -> Bool -> Int -> IO Float
sumFactors :: (SizingTag -> Float -> Float)
-> NodeArena
-> MutablePrimArray RealWorld Int
-> Bool
-> Int
-> IO Float
sumFactors SizingTag -> Float -> Float
factor NodeArena
na MutablePrimArray RealWorld Int
idxArr Bool
horizontal Int
n = Int -> Float -> IO Float
go Int
0 Float
0
  where
    go :: Int -> Float -> IO Float
go !Int
i !Float
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
acc
      | Bool
otherwise = do
          ci <- 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
idxArr Int
i
          (tag, val) <- getAxisSizing na ci horizontal
          go (i + 1) (acc + factor tag val)

{-# INLINE growFactor #-}
growFactor :: SizingTag -> Float -> Float
growFactor :: SizingTag -> Float -> Float
growFactor SizingTag
tag Float
val = if SizingTag
tag SizingTag -> SizingTag -> Bool
forall a. Eq a => a -> a -> Bool
== SizingTag
SizingGrow then Float
val else Float
0

{-# INLINE shrinkFactor #-}
shrinkFactor :: SizingTag -> Float -> Float
shrinkFactor :: SizingTag -> Float -> Float
shrinkFactor SizingTag
tag Float
val =
  case SizingTag
tag of
    SizingTag
SizingShrink -> Float
val
    -- Grow also gives space back when the window is smaller than content.
    SizingTag
SizingGrow -> if Float
val Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
val else Float
1
    -- Percent flexes like CSS: when siblings plus gaps overflow the axis,
    -- percent children give the overflow back so e.g. two 50% columns and a
    -- gap land exactly on the row width. Covers percent on either axis,
    -- should height percent ever be sized that way.
    SizingTag
SizingPercent -> Float
1
    -- Fit stays content-sized. A pinned header must not squash when a Grow
    -- sibling (page scroll) is taller than the window.
    SizingTag
_ -> Float
0

markGrowFlags :: NodeArena -> MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Int -> Int -> IO ()
markGrowFlags :: NodeArena
-> MutablePrimArray RealWorld Int
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Bool
-> Int
-> Int
-> IO ()
markGrowFlags NodeArena
na MutablePrimArray RealWorld Int
idxArr MutablePrimArray RealWorld Float
wArr MutablePrimArray RealWorld Float
hArr MutablePrimArray RealWorld Float
mainArr MutablePrimArray RealWorld Float
crossArr Bool
horizontal !Int
i !Int
end
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = do
      ci <- 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
idxArr Int
i
      iw <- readPrimArray wArr i
      ih <- readPrimArray hArr i
      (tag, val) <- getAxisSizing na ci horizontal
      let gf = SizingTag -> Float -> Float
growFactor SizingTag
tag Float
val
      writePrimArray mainArr i (if horizontal then iw else ih)
      writePrimArray crossArr i (if gf > 0 then gf else 0)
      markGrowFlags na idxArr wArr hArr mainArr crossArr horizontal (i + 1) end

-- One sweep: sum content of non-grow + already-locked children (factor 0) and
-- grow factors of the still-unlocked.
{-# INLINE scanGrow #-}
scanGrow :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Int -> Int -> Float -> Float -> IO (Float, Float)
scanGrow :: MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Int
-> Int
-> Float
-> Float
-> IO (Float, Float)
scanGrow MutablePrimArray RealWorld Float
mainArr MutablePrimArray RealWorld Float
crossArr !Int
i !Int
end !Float
occupied !Float
gfSum
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = (Float, Float) -> IO (Float, Float)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float
occupied, Float
gfSum)
  | Bool
otherwise = do
      gf <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
crossArr Int
i
      if gf > 0
        then scanGrow mainArr crossArr (i + 1) end occupied (gfSum + gf)
        else do
          main <- readPrimArray mainArr i
          scanGrow mainArr crossArr (i + 1) end (occupied + main) gfSum

-- Pin every grow child whose content exceeds its would-be share by clearing
-- its factor; its content stays in mainArr.
lockGrow :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Float -> Float -> Int -> Int -> Int -> IO Int
lockGrow :: MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Float
-> Float
-> Int
-> Int
-> Int
-> IO Int
lockGrow MutablePrimArray RealWorld Float
mainArr MutablePrimArray RealWorld Float
crossArr !Float
free !Float
gfSum !Int
i !Int
end !Int
acc
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
acc
  | Bool
otherwise = do
      gf <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
crossArr Int
i
      if gf > 0
        then do
          need <- readPrimArray mainArr i
          if need * gfSum > gf * free
            then do
              writePrimArray crossArr i 0
              lockGrow mainArr crossArr free gfSum (i + 1) end (acc + 1)
            else lockGrow mainArr crossArr free gfSum (i + 1) end acc
        else lockGrow mainArr crossArr free gfSum (i + 1) end acc

-- Each lock shrinks the share pool, possibly locking more children; the
-- locked set only grows, so this fixpoints within n sweeps.
settleGrow :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Float -> Float -> Int -> Int -> IO (Float, Float)
settleGrow :: MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Float
-> Float
-> Int
-> Int
-> IO (Float, Float)
settleGrow MutablePrimArray RealWorld Float
mainArr MutablePrimArray RealWorld Float
crossArr Float
avail Float
gapSum Int
n !Int
passes = do
  (occupied, gfSum) <- MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Int
-> Int
-> Float
-> Float
-> IO (Float, Float)
scanGrow MutablePrimArray RealWorld Float
mainArr MutablePrimArray RealWorld Float
crossArr Int
0 Int
n Float
0 Float
0
  let free = Float
avail Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gapSum Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
occupied
  locked <- lockGrow mainArr crossArr free gfSum 0 n 0
  if locked == 0 || passes <= 1
    then pure (free, gfSum)
    else settleGrow mainArr crossArr avail gapSum n (passes - 1)

-- Hand shares to unlocked grow children and restore real cross sizes where
-- the factors clobbered them.
applyGrowShares :: MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Float -> Float -> Int -> Int -> IO ()
applyGrowShares :: MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Bool
-> Float
-> Float
-> Int
-> Int
-> IO ()
applyGrowShares MutablePrimArray RealWorld Float
wArr MutablePrimArray RealWorld Float
hArr MutablePrimArray RealWorld Float
mainArr MutablePrimArray RealWorld Float
crossArr Bool
horizontal !Float
free !Float
gfSum !Int
i !Int
end
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = do
      iw <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
wArr Int
i
      ih <- readPrimArray hArr i
      gf <- readPrimArray crossArr i
      when (gf > 0) $
        writePrimArray mainArr i (max 0 (free * gf / gfSum))
      writePrimArray crossArr i (if horizontal then ih else iw)
      applyGrowShares wArr hArr mainArr crossArr horizontal free gfSum (i + 1) end

applyShrink :: NodeArena -> MutablePrimArray RealWorld Int -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> MutablePrimArray RealWorld Float -> Bool -> Float -> Float -> Int -> Int -> IO ()
applyShrink :: NodeArena
-> MutablePrimArray RealWorld Int
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> MutablePrimArray RealWorld Float
-> Bool
-> Float
-> Float
-> Int
-> Int
-> IO ()
applyShrink NodeArena
na MutablePrimArray RealWorld Int
idxArr MutablePrimArray RealWorld Float
wArr MutablePrimArray RealWorld Float
hArr MutablePrimArray RealWorld Float
outW MutablePrimArray RealWorld Float
outH Bool
horizontal !Float
overflow !Float
shrinkTotal !Int
i !Int
end
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = do
      ci <- 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
idxArr Int
i
      iw <- readPrimArray wArr i
      ih <- readPrimArray hArr i
      (minW, minH, _, _) <- getMinMax na ci
      (tag, val) <- getAxisSizing na ci horizontal
      let sf = SizingTag -> Float -> Float
shrinkFactor SizingTag
tag Float
val
          main = if Bool
horizontal then Float
iw else Float
ih
          minMain = if Bool
horizontal then Float
minW else Float
minH
          delta = Float
overflow Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
sf Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
shrinkTotal
          shrunk = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minMain (Float
main Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
delta)
      if horizontal
        then writePrimArray outW i shrunk >> writePrimArray outH i ih
        else writePrimArray outW i iw >> writePrimArray outH i shrunk
      applyShrink na idxArr wArr hArr outW outH horizontal overflow shrinkTotal (i + 1) end

alignX :: AlignX -> Float -> Float -> Float -> Float
alignX :: AlignX -> Float -> Float -> Float -> Float
alignX AlignX
AlignStart Float
cx Float
_ Float
_ = Float
cx
alignX AlignX
AlignCenter Float
cx Float
cw Float
iw = Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
cw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
alignX AlignX
AlignEnd Float
cx Float
cw Float
iw = Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw

alignY :: AlignY -> Float -> Float -> Float -> Float
alignY :: AlignY -> Float -> Float -> Float -> Float
alignY AlignY
AlignTop Float
cy Float
_ Float
_ = Float
cy
alignY AlignY
AlignMiddle Float
cy Float
ch Float
ih = Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
ch Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
alignY AlignY
AlignBottom Float
cy Float
ch Float
ih = Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ch Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih
-- Only a row has a baseline to share; 'positionRowFromParent' places these.
alignY AlignY
AlignBaseline Float
cy Float
_ Float
_ = Float
cy

-- | Distance from the top of node @ci@, laid out @h@ tall, to its first
-- baseline, as in CSS:
--
-- * text: its first line's, where paint puts it ('collectNodeTextSpans'). One
--   line is centered in the box, and wrapped lines start at the top. Paint
--   wraps at explicit newlines, and outside a row where the line overflows
--   'textWrapCap'.
-- * a widget with a label (a button, select, checkbox): the label's, which
--   paint centers in the widget.
-- * a container: the baseline its baseline-aligned children share if it is a
--   row that has some, and otherwise its first child's.
-- * anything else: its bottom edge.
childBaseline :: SolveEnv -> NodeIdx -> Float -> IO Float
childBaseline :: SolveEnv -> Int -> Float -> IO Float
childBaseline env :: SolveEnv
env@SolveEnv {seArena :: SolveEnv -> NodeArena
seArena = NodeArena
na, seArrays :: SolveEnv -> NodeArenaArrays
seArrays = NodeArenaArrays
a, seFm :: SolveEnv -> FontMetrics
seFm = FontMetrics
defaultFm, seResolveFont :: SolveEnv -> FontResolver
seResolveFont = FontResolver
resolveFont} Int
ci Float
h = do
  nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
ci
  si <- getStyleIdx na ci
  case nt of
    NodeType
NodeText -> do
      raw <- NodeArena -> Int -> IO Text
getText NodeArena
na Int
ci
      if T.null raw
        then pure h
        else do
          measurer@TextMeasurer {tmMetrics = fm} <- textNodeMeasurer env ci
          rowChild <- parentIsRow na ci
          wrapped <-
            if T.any (== '\n') raw
              then pure True
              else
                if rowChild
                  then pure False
                  else do
                    (_, _, maxW, _) <- getMinMax na ci
                    (wTag, _) <- getWidthSizing na ci
                    (_, _, w, _) <- getRect na ci
                    effMaxW <- if maxW < 1e8 then pure maxW else findAncestorMaxW na ci
                    let cap = Float -> SizingTag -> Float -> Float
textWrapCap Float
effMaxW SizingTag
wTag Float
w
                    (tw, _) <- measureFontLine measurer raw
                    pure (cap < 1e8 && cap + 0.5 < tw)
          pure (textBaseline fm (if wrapped then fmLineHeight fm else h))
    NodeType
_
      | NodeType -> Bool
hasCenteredLabel NodeType
nt Bool -> Bool -> Bool
&& Bool -> Bool
not (NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeButton Bool -> Bool -> Bool
&& Int -> Bool
isCloseButtonStyle Int
si) -> do
          -- Widget labels take the node's font size in the default face
          -- ('resolveFontFor').
          size <- NodeArena -> Int -> IO Float
getNodeFontSize NodeArena
na Int
ci
          let weight = Int -> FontWeight
textNodeFontWeight Int
0
              style = Int -> FontStyle
textNodeFontStyle Int
0
              variant = Int -> FontVariant
textNodeFontVariant Int
0
          fm <-
            if isDefaultNodeFont size weight style variant
              then pure defaultFm
              else fst <$> resolveFont size weight style variant
          pure (textBaseline fm h)
      | NodeType -> Bool
isContainerNode NodeType
nt -> do
          -- Children are linked last first, so consing them up as they are
          -- visited leaves the list in child order.
          kids <- NodeArena -> Int -> ([Int] -> Int -> IO [Int]) -> [Int] -> IO [Int]
forall acc.
NodeArena -> Int -> (acc -> Int -> IO acc) -> acc -> IO acc
foldFlowChildrenM NodeArena
na Int
ci (\[Int]
acc Int
k -> [Int] -> IO [Int]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
k Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc)) []
          case kids of
            [] -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
h
            Int
first : [Int]
_ -> do
              (pad, _, dir) <- NodeArenaArrays -> Int -> IO (Padding, Float, DirTag)
containerFlow NodeArenaArrays
a Int
ci
              let innerH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padT Padding
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Padding -> Float
padB Padding
pad)
                  heightOf Int
k = (\(Float
_, Float
_, Float
_, Float
kh) -> Float
kh) ((Float, Float, Float, Float) -> Float)
-> IO (Float, Float, Float, Float) -> IO Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect NodeArena
na Int
k
              grouped <-
                if dir /= DirRow
                  then pure []
                  else
                    fmap concat . forM kids $ \Int
k -> do
                      ay <- NodeArena -> Int -> IO AlignY
getAlignY NodeArena
na Int
k
                      if ay /= AlignBaseline then pure [] else (: []) <$> (heightOf k >>= childBaseline env k)
              (padT pad +) <$> case grouped of
                Float
_ : [Float]
_ -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
grouped)
                [] -> do
                  fh <- Int -> IO Float
heightOf Int
first
                  ay <- if dir == DirRow then getAlignY na first else pure AlignTop
                  (alignY ay 0 innerH fh +) <$> childBaseline env first fh
      | Bool
otherwise -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
h
  where
    textBaseline :: FontMetrics -> Float -> Float
textBaseline FontMetrics
fm Float
boxH = FontMetrics -> Float -> Float -> Float -> Float
centeredTextY FontMetrics
fm Float
0 Float
boxH (FontMetrics -> Float
fmLineHeight FontMetrics
fm) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Float
fmAscent FontMetrics
fm

placeModals :: NodeArena -> Measurers -> Float -> Float -> IO ()
placeModals :: NodeArena -> Measurers -> Float -> Float -> IO ()
placeModals NodeArena
na Measurers
ms Float
winW Float
winH = do
  env <- NodeArena -> Measurers -> IO SolveEnv
solveEnv NodeArena
na Measurers
ms
  let margin = Float
windowMargin
  forNodes_ na $ \Int
idx -> do
    nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
    when (nt == NodeModal) $ do
      (_, _, iw, ih) <- getRect na idx
      let maxW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
margin)
          maxH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
margin)
          w = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
iw Float
maxW
          h = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
ih Float
maxH
          x = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 ((Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
w) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
          y = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 ((Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
h) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
      positionNodeA env 0 idx x y w h

placeWindows ::
  NodeArena ->
  Measurers ->
  Float ->
  Float ->
  (WidgetId -> IO (Maybe (Float, Float))) ->
  (WidgetId -> IO (Maybe (Float, Float))) ->
  IO ()
placeWindows :: NodeArena
-> Measurers
-> Float
-> Float
-> (WidgetId -> IO (Maybe (Float, Float)))
-> (WidgetId -> IO (Maybe (Float, Float)))
-> IO ()
placeWindows NodeArena
na Measurers
ms Float
winW Float
winH WidgetId -> IO (Maybe (Float, Float))
lookupPos WidgetId -> IO (Maybe (Float, Float))
lookupSize = do
  let margin :: Float
margin = Float
windowMargin
  NodeArena -> (Int -> IO ()) -> IO ()
forNodes_ NodeArena
na ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
idx -> do
    nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
    when (nt == NodeWindow) $ do
      wid <- getWidgetId na idx
      (_, _, iw, ih) <- getRect na idx
      (w0, h0) <- fromMaybe (min iw winW, min ih winH) <$> lookupSize wid
      mpos <- lookupPos wid
      placeWindowNode na ms winW winH idx w0 h0 $ \Float
w -> (Float, Float) -> Maybe (Float, Float) -> (Float, Float)
forall a. a -> Maybe a -> a
fromMaybe (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin, Float
margin) Maybe (Float, Float)
mpos

-- | Lay out window @idx@ at size @w0 h0@, clamped to its min and max size and
-- the screen, with its origin, given that size, clamped on screen. Fit sizing
-- caps at intrinsic size; floating windows use an explicit frame size.
placeWindowNode :: NodeArena -> Measurers -> Float -> Float -> NodeIdx -> Float -> Float -> (Float -> (Float, Float)) -> IO ()
placeWindowNode :: NodeArena
-> Measurers
-> Float
-> Float
-> Int
-> Float
-> Float
-> (Float -> (Float, Float))
-> IO ()
placeWindowNode NodeArena
na Measurers
ms Float
winW Float
winH Int
idx Float
w0 Float
h0 Float -> (Float, Float)
originFor = do
  (minW, minH, maxW, maxH) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getMinMax NodeArena
na Int
idx
  let w = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minW (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
maxW Float
winW) Float
w0
      h = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minH (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
maxH Float
winH) Float
h0
      (x0, y0) = originFor w
      x = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
w)) Float
x0
      y = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
h)) Float
y0
  setRect na idx x y w h
  env <- solveEnv na ms
  (pad, gap, dir) <- containerFlow (seArrays env) idx
  positionChildren env 0 idx dir gap pad x y w h

-- | Horizontal placement for a widget-anchored popup. Aligns the popup's left
-- edge with the anchor even when the anchor sits inside the window margin (a
-- menu bar flush to the left, say); the margin is only there to keep the popup
-- clear of the right edge.
clampPopupX :: Float -> Float -> Float -> Float -> Float
clampPopupX :: Float -> Float -> Float -> Float -> Float
clampPopupX Float
margin Float
winW Float
iw Float
x0
  | Float
x0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
margin Bool -> Bool -> Bool
&& Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
iw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
winW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
x0
  | Bool
otherwise = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
margin (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin) Float
x0)

computePopupPosition ::
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  PopupAnchor ->
  PopupPlacement ->
  Float ->
  (Float, Float)
computePopupPosition :: Float
-> Float
-> Float
-> Float
-> Float
-> PopupAnchor
-> PopupPlacement
-> Float
-> (Float, Float)
computePopupPosition Float
winW Float
winH Float
margin Float
iw Float
ih PopupAnchor
anchor PopupPlacement
placement Float
offset =
  case PopupAnchor
anchor of
    AnchorPoint (V2 Float
px Float
py) ->
      let x0 :: Float
x0 = case PopupPlacement
placement of
            PopupPlacement
PlacementLeft -> Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
            PopupPlacement
PlacementRight -> Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
            PopupPlacement
_ -> Float
px
          y0 :: Float
y0 = case PopupPlacement
placement of
            PopupPlacement
PlacementAbove -> Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
            PopupPlacement
PlacementBelow -> Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
            PopupPlacement
_ -> Float
py
          x :: Float
x = if Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
iw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin Bool -> Bool -> Bool
&& Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
0
                then Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
                else Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
margin (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin) Float
x0)
          y :: Float
y = if Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ih Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin Bool -> Bool -> Bool
&& Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
0
                then Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
                else Float -> Float
clampY Float
y0
       in (Float
x, Float
y)
    AnchorRect (Rect Float
rx Float
ry Float
rw Float
rh) ->
      case PopupPlacement
placement of
        PopupPlacement
PlacementBelow ->
          let x0 :: Float
x0 = Float
rx
              y0 :: Float
y0 = Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
              y :: Float
y = if Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ih Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin Bool -> Bool -> Bool
&& Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
margin
                    then Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
                    else Float
y0
              x :: Float
x = Float -> Float -> Float -> Float -> Float
clampPopupX Float
margin Float
winW Float
iw Float
x0
           in (Float
x, Float -> Float
clampY Float
y)
        PopupPlacement
PlacementAbove ->
          let x0 :: Float
x0 = Float
rx
              y0 :: Float
y0 = Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
              y :: Float
y = if Float
y0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
margin Bool -> Bool -> Bool
&& Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ih Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin
                    then Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
                    else Float
y0
              x :: Float
x = Float -> Float -> Float -> Float -> Float
clampPopupX Float
margin Float
winW Float
iw Float
x0
           in (Float
x, Float -> Float
clampY Float
y)
        PopupPlacement
PlacementRight ->
          let x0 :: Float
x0 = Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rw Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
              y0 :: Float
y0 = Float
ry
              x :: Float
x = if Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
iw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin Bool -> Bool -> Bool
&& Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
margin
                    then Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
                    else Float
x0
              y :: Float
y = Float -> Float
clampY Float
y0
           in (Float -> Float -> Float -> Float -> Float
clampPopupX Float
margin Float
winW Float
iw Float
x, Float
y)
        PopupPlacement
PlacementLeft ->
          let x0 :: Float
x0 = Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
              y0 :: Float
y0 = Float
ry
              x :: Float
x = if Float
x0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
margin Bool -> Bool -> Bool
&& Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rw Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
iw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin
                    then Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rw Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
                    else Float
x0
              y :: Float
y = Float -> Float
clampY Float
y0
           in (Float -> Float -> Float -> Float -> Float
clampPopupX Float
margin Float
winW Float
iw Float
x, Float
y)
        PopupPlacement
PlacementAuto ->
          let spaceBelow :: Float
spaceBelow = Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset)
              spaceAbove :: Float
spaceAbove = Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin
              y :: Float
y = if Float
spaceBelow Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
ih Bool -> Bool -> Bool
|| Float
spaceBelow Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
spaceAbove
                    then Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset
                    else Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
offset
              x :: Float
x = Float -> Float -> Float -> Float -> Float
clampPopupX Float
margin Float
winW Float
iw Float
rx
           in (Float
x, Float -> Float
clampY Float
y)
        PopupPlacement
PlacementAtCursor ->
          (Float -> Float -> Float -> Float -> Float
clampPopupX Float
margin Float
winW Float
iw Float
rx, Float -> Float
clampY (Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset))
  where
    -- Keep the popup's top edge within the window margins.
    clampY :: Float -> Float
clampY Float
y = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
margin (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ih Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin) Float
y)

placePopups ::
  NodeArena ->
  Measurers ->
  Float ->
  Float ->
  (WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float))) ->
  IO ()
placePopups :: NodeArena
-> Measurers
-> Float
-> Float
-> (WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float)))
-> IO ()
placePopups NodeArena
na Measurers
ms Float
winW Float
winH WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float))
lookupAnchor = do
  env <- NodeArena -> Measurers -> IO SolveEnv
solveEnv NodeArena
na Measurers
ms
  let margin = Float
windowMargin
  forNodes_ na $ \Int
idx -> do
    nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
    when (nt == NodePopup) $ do
      wid <- getWidgetId na idx
      (_, _, iw, ih) <- getRect na idx
      mcfg <- lookupAnchor wid
      let (anchor, placement, offset) = case mcfg of
            Just (PopupAnchor
a, PopupPlacement
p, Float
o) -> (PopupAnchor
a, PopupPlacement
p, Float
o)
            Maybe (PopupAnchor, PopupPlacement, Float)
Nothing -> (V2 -> PopupAnchor
AnchorPoint (Float -> Float -> V2
V2 Float
0 Float
0), PopupPlacement
PlacementAuto, Float
4)
          (x, y) = computePopupPosition winW winH margin iw ih anchor placement offset
      positionNodeA env 0 idx x y iw ih