module NanoUI.Damage
  ( updatePrevRects
  , floatingPanelRects
  , FrameSnapshot (..)
  , writeDamage
  ) where

import Control.Monad (forM_, join, unless, when)
import Data.IORef (readIORef)
import Data.IntMap.Strict qualified as IM
import Data.IntSet qualified as IS
import Data.Maybe (fromMaybe, isJust)
import Data.Primitive.PrimArray (MutablePrimArray, newPrimArray, readPrimArray, writePrimArray)
import Data.Text (Text)
import GHC.Exts (RealWorld)
import NanoUI.Context
  ( Animation
  , Context (..)
  , DamageRequest (..)
  , WidgetStore (..)
  , getHotId
  , getLiveAnimations
  , getAnimRest
  , pruneAnimRest
  , getAnimRectless
  , getPrevRect
  , getStore
  , getWindowDrag
  , getWindowResize
  , intKey
  , markDirty
  , modalDamageFlip
  , setAnimRectless
  , takeAnimSettled
  , lookupCustomDamageSlop
  , lookupCustomDrawing
  , lookupDrawing
  , refreshCustomDrawingOps
  , drawingOpsStale
  , CustomDrawingEntry (..)
  , DrawingEntry (..)
  , DamageState (..)
  , OverlayState (..)
  , getsDamage
  , modifyDamage
  , modifyOverlay
  )
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input
  ( Input (..)
  , inputWindowSize
  )
import NanoUI.Frame.Hit (findNodeByKey)
import NanoUI.Store (eqByPtr, mirrorStoresChanged, ptrEq, slotKey, Slot (..))
import NanoUI.Layout.Arena
  ( NodeArena
  , NodeType (..)
  , SizingTag (..)
  , arenaCount
  , foldNodeRevM
  , getClipRect
  , getHeightSizing
  , getNodeType
  , getParent
  , getRect
  , getStyleIdx
  , getText
  , getWidgetId
  , getWidthSizing
  , isFloatingNode
  , isScrollNode
  )
import NanoUI.Frame.Scroll.Geometry (decodeScrollConfig, scrollBare)
import NanoUI.Widgets.Custom (mkCustomDrawContext)
import NanoUI.Types
  ( Damage (..)
  , Rect (..)
  , Size (..)
  , defaultDamageSlop
  , rectArea
  , rectFullyInside
  , rectInflate
  , rectIntersect
  , rectNonEmpty
  , rectUnion
  , resolveDamageRect
  )

layoutSettleMinArea :: Float
layoutSettleMinArea :: Float
layoutSettleMinArea = Float
0.25

-- | Bound on how many consecutive rect-less frames a live animation may force a
-- full-window repaint. An animation whose widget is about to be laid out for the
-- first time gets a couple of frames of DamageFull cover; a perpetual animation
-- whose widget has left the arena (e.g. `keepAnimating` behind a tab switch)
-- must stop repainting the whole window once it is clearly gone.
orphanEscalateFrames :: Int
orphanEscalateFrames :: Int
orphanEscalateFrames = Int
2

-- Partial retain clears with themeWindow. Expand interaction clips to the painted
-- panel/window backdrop so slop pixels get the correct fill, not window color.
backdropRectFromNode :: Context -> Int -> IO (Maybe Rect)
backdropRectFromNode :: Context -> Int -> IO (Maybe Rect)
backdropRectFromNode Context
ctx Int
idx = (Int -> IO (Maybe Rect)) -> NodeArena -> Int -> IO (Maybe Rect)
forall a. (Int -> IO (Maybe a)) -> NodeArena -> Int -> IO (Maybe a)
walkAncestors Int -> IO (Maybe Rect)
step (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  where
    step :: Int -> IO (Maybe Rect)
step Int
i = do
      let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
      nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
i
      if nt == NodePanel || isFloatingNode nt
        then getNonzeroRect na i
        else case nt of
          NodeType
NodeScrollContainer -> do
            (wTag, _) <- NodeArena -> Int -> IO (SizingTag, Float)
getWidthSizing NodeArena
na Int
i
            (hTag, _) <- getHeightSizing na i
            si <- getStyleIdx na i
            if (wTag == SizingGrow && hTag == SizingGrow) || scrollBare (decodeScrollConfig si)
              then pure Nothing
              else getNonzeroRect na i
          NodeType
_ -> Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Rect
forall a. Maybe a
Nothing

{-# INLINE walkAncestors #-}
walkAncestors :: (Int -> IO (Maybe a)) -> NodeArena -> Int -> IO (Maybe a)
walkAncestors :: forall a. (Int -> IO (Maybe a)) -> NodeArena -> Int -> IO (Maybe a)
walkAncestors Int -> IO (Maybe a)
step NodeArena
arena Int
idx = Int -> IO (Maybe a)
loop Int
idx
  where
    loop :: Int -> IO (Maybe a)
loop Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          mr <- Int -> IO (Maybe a)
step Int
i
          case mr of
            Just a
x -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
            Maybe a
Nothing -> NodeArena -> Int -> IO Int
getParent NodeArena
arena Int
i IO Int -> (Int -> IO (Maybe a)) -> IO (Maybe a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO (Maybe a)
loop

{-# INLINE getNonzeroRect #-}
getNonzeroRect :: NodeArena -> Int -> IO (Maybe Rect)
getNonzeroRect :: NodeArena -> Int -> IO (Maybe Rect)
getNonzeroRect NodeArena
arena Int
i = do
  (x, y, w, h) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect NodeArena
arena Int
i
  let r = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
  pure (if rectNonEmpty r then Just r else Nothing)

updatePrevRects :: Context -> IO ()
updatePrevRects :: Context -> IO ()
updatePrevRects Context
ctx = do
  live <- Context -> IO (IntMap Animation)
getLiveAnimations Context
ctx
  prevRectless <- getAnimRectless ctx
  oldRects <- getsDamage ctx dsPrevRects
  oldClips <- getsDamage ctx dsPrevClips
  oldTexts <- getsDamage ctx dsPrevNodeTexts
  let na = Context -> NodeArena
ctxNodeArena Context
ctx
      bump IntMap Rect
rects = do
        rest <- Context -> IO (IntMap Float)
getAnimRest Context
ctx
        let rectless' =
              (Int -> Int) -> IntSet -> IntMap Int
forall a. (Int -> a) -> IntSet -> IntMap a
IM.fromSet
                (\Int
k -> if Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
k IntMap Rect
rects then Int
0 else Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
k IntMap Int
prevRectless Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                (IntMap Animation -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet IntMap Animation
live IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntMap Float -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet IntMap Float
rest)
            deadRest = (Int -> Float -> Bool) -> IntMap Float -> IntMap Float
forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IM.filterWithKey (\Int
k Float
_ -> Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
k IntMap Int
rectless' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
300) IntMap Float
rest
        unless (IM.null deadRest) $
          pruneAnimRest ctx (\Int
k -> Int -> IntMap Float -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember Int
k IntMap Float
deadRest)
        -- Every key is live or resting, so this drops exactly the dead resting
        -- keys that are not live again.
        setAnimRectless ctx (rectless' `IM.difference` (deadRest `IM.difference` live))
  count <- arenaCount na
  if count <= 0
    then do
      modifyDamage ctx (\DamageState
ds -> DamageState
ds {dsPrevRects = IM.empty, dsPrevClips = IM.empty, dsPrevNodeTexts = IM.empty})
      bump IM.empty
    else do
      -- Walk the arena from base maps, touching only entries whose value
      -- changed. Seeded with last frame's maps, frames with stable rects
      -- (hover, text churn, animations) allocate nothing. The walk cannot
      -- delete keys that vanished from the arena, so when the key set changed
      -- it reruns from empty maps, where no key counts as old.
      let go IntMap Rect
olds !Int
i !IntMap Rect
m !IntMap Rect
cm !IntMap Text
tm !Int
foundOld !Bool
dropped
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
count =
                if Bool
dropped Bool -> Bool -> Bool
|| Int
foundOld Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= IntMap Rect -> Int
forall a. IntMap a -> Int
IM.size IntMap Rect
olds
                  then IntMap Rect
-> Int
-> IntMap Rect
-> IntMap Rect
-> IntMap Text
-> Int
-> Bool
-> IO ()
go IntMap Rect
forall a. IntMap a
IM.empty Int
0 IntMap Rect
forall a. IntMap a
IM.empty IntMap Rect
forall a. IntMap a
IM.empty IntMap Text
forall a. IntMap a
IM.empty Int
0 Bool
False
                  else do
                    Context -> (DamageState -> DamageState) -> IO ()
modifyDamage Context
ctx (\DamageState
ds -> DamageState
ds {dsPrevRects = m, dsPrevClips = cm, dsPrevNodeTexts = tm})
                    IntMap Rect -> IO ()
bump IntMap Rect
m
            | Bool
otherwise = do
                wid <- NodeArena -> Int -> IO WidgetId
getWidgetId NodeArena
na Int
i
                if hashWidgetId wid == 0
                  then go olds (i + 1) m cm tm foundOld dropped
                  else do
                    let !k = WidgetId -> Int
intKey WidgetId
wid
                        isOld = Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
k IntMap Rect
olds
                    mRect <- getNonzeroRect na i
                    case mRect of
                      Maybe Rect
Nothing ->
                        let dropped' :: Bool
dropped' = Bool
dropped Bool -> Bool -> Bool
|| Bool
isOld
                            m' :: IntMap Rect
m' = if Bool
isOld then Int -> IntMap Rect -> IntMap Rect
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
k IntMap Rect
m else IntMap Rect
m
                            cm' :: IntMap Rect
cm' = if Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
k IntMap Rect
cm then Int -> IntMap Rect -> IntMap Rect
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
k IntMap Rect
cm else IntMap Rect
cm
                            tm' :: IntMap Text
tm' = if Int -> IntMap Text -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
k IntMap Text
tm then Int -> IntMap Text -> IntMap Text
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
k IntMap Text
tm else IntMap Text
tm
                         in IntMap Rect
-> Int
-> IntMap Rect
-> IntMap Rect
-> IntMap Text
-> Int
-> Bool
-> IO ()
go IntMap Rect
olds (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) IntMap Rect
m' IntMap Rect
cm' IntMap Text
tm' Int
foundOld Bool
dropped'
                      Just Rect
r -> do
                        mClip <- NodeArena -> Int -> IO (Maybe Rect)
getClipRect NodeArena
na Int
i
                        nt <- getNodeType na i
                        let !m' = if Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
m Maybe Rect -> Maybe Rect -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
r then IntMap Rect
m else Int -> Rect -> IntMap Rect -> IntMap Rect
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k Rect
r IntMap Rect
m
                            !cm' = case Maybe Rect
mClip of
                              Just Rect
c -> if Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
cm Maybe Rect -> Maybe Rect -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
c then IntMap Rect
cm else Int -> Rect -> IntMap Rect -> IntMap Rect
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k Rect
c IntMap Rect
cm
                              Maybe Rect
Nothing -> if Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
k IntMap Rect
cm then Int -> IntMap Rect -> IntMap Rect
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
k IntMap Rect
cm else IntMap Rect
cm
                        -- Text nodes, and images, whose text is their image
                        -- id: switching an image repaints it like new text.
                        tm' <-
                          if nt == NodeText || nt == NodeImage
                            then do
                              txt <- getText na i
                              pure $! if IM.lookup k tm == Just txt then tm else IM.insert k txt tm
                            else pure $! if IM.member k tm then IM.delete k tm else tm
                        go olds (i + 1) m' cm' tm' (foundOld + if isOld then 1 else 0) dropped
      go oldRects 0 oldRects oldClips oldTexts 0 False

floatingPanelsInOrder :: Context -> IO [(Int, Rect)]
floatingPanelsInOrder :: Context -> IO [(Int, Rect)]
floatingPanelsInOrder Context
ctx = NodeArena
-> ([(Int, Rect)] -> Int -> IO [(Int, Rect)])
-> [(Int, Rect)]
-> IO [(Int, Rect)]
forall a. NodeArena -> (a -> Int -> IO a) -> a -> IO a
foldNodeRevM NodeArena
na [(Int, Rect)] -> Int -> IO [(Int, Rect)]
step []
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    step :: [(Int, Rect)] -> Int -> IO [(Int, Rect)]
step [(Int, Rect)]
acc Int
idx = do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
      if not (isFloatingNode nt)
        then pure acc
        else do
          wid <- getWidgetId na idx
          if hashWidgetId wid == 0
            then pure acc
            else do
              (x, y, w, h) <- getRect na idx
              pure ((intKey wid, Rect x y w h) : acc)

floatingPanelRects :: Context -> IO (IM.IntMap Rect)
floatingPanelRects :: Context -> IO (IntMap Rect)
floatingPanelRects Context
ctx = [(Int, Rect)] -> IntMap Rect
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, Rect)] -> IntMap Rect)
-> IO [(Int, Rect)] -> IO (IntMap Rect)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO [(Int, Rect)]
floatingPanelsInOrder Context
ctx

-- | State 'NanoUI.Frame' captures before the UI pass; 'writeDamage' compares
-- it against the finished frame.
data FrameSnapshot = FrameSnapshot
  { FrameSnapshot -> Bool
fsWasDirty :: !Bool
  , FrameSnapshot -> Size
fsSize :: !Size
  , FrameSnapshot -> WidgetStore
fsStore :: !WidgetStore
  , FrameSnapshot -> WidgetId
fsHot :: !WidgetId
  , FrameSnapshot -> WidgetId
fsActive :: !WidgetId
  , FrameSnapshot -> WidgetId
fsFocus :: !WidgetId
  , FrameSnapshot -> Maybe Rect
fsHotRect :: !(Maybe Rect)
  , FrameSnapshot -> Maybe Rect
fsActiveRect :: !(Maybe Rect)
  , FrameSnapshot -> Maybe Rect
fsFocusRect :: !(Maybe Rect)
  , FrameSnapshot -> IntMap Rect
fsFloatingRects :: !(IM.IntMap Rect)
  , FrameSnapshot -> IntMap Rect
fsRects :: !(IM.IntMap Rect)
  , FrameSnapshot -> IntMap Text
fsTexts :: !(IM.IntMap Text)
  , FrameSnapshot -> IntSet
fsAnimKeys :: !IS.IntSet
  }

-- | What the finished frame looks like and what changed since the snapshot.
-- Derived fields stay lazy: a frame that is already 'DamageFull' for a cheap
-- reason never pays for them.
data FrameDelta = FrameDelta
  { FrameDelta -> Size
fdWinSize :: !Size
  , FrameDelta -> Bool
fdOverlayOpen :: !Bool
  , FrameDelta -> WidgetStore
fdStore :: !WidgetStore
  , FrameDelta -> IntMap Rect
fdRects :: !(IM.IntMap Rect)
  , FrameDelta -> IntMap Text
fdTexts :: !(IM.IntMap Text)
  , FrameDelta -> IntMap Rect
fdFloatingRects :: !(IM.IntMap Rect)
  , FrameDelta -> Bool
fdModalFlip :: !Bool
  , FrameDelta -> IntMap Animation
fdLiveAnims :: !(IM.IntMap Animation)
  , FrameDelta -> IntMap Int
fdRectless :: !(IM.IntMap Int)
  , FrameDelta -> Bool
fdWindowLive :: !Bool
  , FrameDelta -> [DamageRequest]
fdRequests :: ![DamageRequest]
  , FrameDelta -> Bool
fdAnimLive :: Bool
  , FrameDelta -> Bool
fdFloatingChanged :: Bool
  , FrameDelta -> Bool
fdScrollChanged :: Bool
  , FrameDelta -> Bool
fdPointsChanged :: Bool
  , FrameDelta -> Bool
fdScrollOnly :: Bool
  -- ^ Only 'storeFloat' changed in the store, e.g. a floating pane scrolled.
  , FrameDelta -> RectGroup
fdSettledMoved :: !RectGroup
  -- ^ Changed key rects, clipped to their scroll viewports, that cover some
  -- area.
  , FrameDelta -> RectGroup
fdChurn :: !RectGroup
  -- ^ Rects of keys that left or joined the arena.
  , FrameDelta -> [Int]
fdRedrawn :: ![Int]
  -- ^ Keys of drawings whose ops changed at an unchanged rect.
  }

writeDamage :: Context -> Input -> Bool -> FrameSnapshot -> IO ()
writeDamage :: Context -> Input -> Bool -> FrameSnapshot -> IO ()
writeDamage Context
ctx Input
inp Bool
overlayOpen FrameSnapshot
snap = do
  newStore <- Context -> IO WidgetStore
getStore Context
ctx
  panels <- floatingPanelsInOrder ctx
  newRects <- getsDamage ctx dsPrevRects
  newTexts <- getsDamage ctx dsPrevNodeTexts
  modalFlip <- modalDamageFlip ctx
  liveAnims <- getLiveAnimations ctx
  settled <- takeAnimSettled ctx
  rectless <- getAnimRectless ctx
  winDragActive <- isJust <$> getWindowDrag ctx
  winResizeActive <- isJust <$> getWindowResize ctx
  requests <- getsDamage ctx dsRequests
  redrawn <- refreshCustomDrawings ctx
  let oldRects = FrameSnapshot -> IntMap Rect
fsRects FrameSnapshot
snap
      oldStore = FrameSnapshot -> WidgetStore
fsStore FrameSnapshot
snap
      newFloatingRects = [(Int, Rect)] -> IntMap Rect
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int, Rect)]
panels
  (settledMoved, churn) <- rectDeltas ctx (map snd panels) oldRects newRects
  let scrollChanged = Bool -> Bool
not (IntMap Float -> IntMap Float -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap Float
storeFloat WidgetStore
oldStore) (WidgetStore -> IntMap Float
storeFloat WidgetStore
newStore))
      delta =
        FrameDelta
          { fdWinSize :: Size
fdWinSize = Input -> Size
inputWindowSize Input
inp
          , fdOverlayOpen :: Bool
fdOverlayOpen = Bool
overlayOpen
          , fdStore :: WidgetStore
fdStore = WidgetStore
newStore
          , fdRects :: IntMap Rect
fdRects = IntMap Rect
newRects
          , fdTexts :: IntMap Text
fdTexts = IntMap Text
newTexts
          , fdFloatingRects :: IntMap Rect
fdFloatingRects = IntMap Rect
newFloatingRects
          , fdModalFlip :: Bool
fdModalFlip = Bool
modalFlip
          , fdLiveAnims :: IntMap Animation
fdLiveAnims = IntMap Animation
liveAnims
          , fdRectless :: IntMap Int
fdRectless = IntMap Int
rectless
          , fdWindowLive :: Bool
fdWindowLive = Bool
winDragActive Bool -> Bool -> Bool
|| Bool
winResizeActive
          , fdRequests :: [DamageRequest]
fdRequests = [DamageRequest]
requests
          , fdAnimLive :: Bool
fdAnimLive = Bool -> Bool
not (IntMap Animation -> Bool
forall a. IntMap a -> Bool
IM.null IntMap Animation
liveAnims) Bool -> Bool -> Bool
|| Bool
settled
          , fdFloatingChanged :: Bool
fdFloatingChanged = FrameSnapshot -> IntMap Rect
fsFloatingRects FrameSnapshot
snap IntMap Rect -> IntMap Rect -> Bool
forall a. Eq a => a -> a -> Bool
/= IntMap Rect
newFloatingRects
          , fdScrollChanged :: Bool
fdScrollChanged = Bool
scrollChanged
          , fdPointsChanged :: Bool
fdPointsChanged = Bool -> Bool
not (IntMap (Float, Float) -> IntMap (Float, Float) -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
oldStore) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
newStore))
          , fdScrollOnly :: Bool
fdScrollOnly =
              Bool
scrollChanged Bool -> Bool -> Bool
&& WidgetStore
oldStore WidgetStore -> WidgetStore -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetStore
newStore {storeFloat = storeFloat oldStore}
          , fdSettledMoved :: RectGroup
fdSettledMoved = RectGroup
settledMoved
          , fdChurn :: RectGroup
fdChurn = RectGroup
churn
          , fdRedrawn :: [Int]
fdRedrawn = [Int]
redrawn
          }
  dmg <-
    if needsFullDamage snap delta
      then pure DamageFull
      else clipDamage ctx snap delta
  modifyDamage ctx (\DamageState
ds -> DamageState
ds {dsDamage = dmg, dsLastWindowSize = inputWindowSize inp, dsRequests = []})
  modifyOverlay ctx (\OverlayState
os -> OverlayState
os {osPrevFloatingRects = newFloatingRects, osPrevFloatingOrder = map fst panels})
  when modalFlip (markDirty ctx)
  when (fdFloatingChanged delta && not (IM.null (fsFloatingRects snap) && not (IM.null newFloatingRects))) $
    markDirty ctx

-- | Settle every drawing's ops for this frame and return the keys of those
-- that now draw something else at an unchanged rect. A drawing follows state
-- the arena does not hold, so nothing else damages it, and paint must not
-- replay the previous frame's ops for it. What this costs per widget is the
-- widget's own choice: see 'refreshCustomDrawingOps'.
refreshCustomDrawings :: Context -> IO [Int]
refreshCustomDrawings :: Context -> IO [Int]
refreshCustomDrawings Context
ctx = NodeArena -> IO Int
arenaCount NodeArena
na IO Int -> (Int -> IO [Int]) -> IO [Int]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
count -> Int -> Int -> [Int] -> IO [Int]
go Int
count Int
0 []
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    go :: Int -> Int -> [Int] -> IO [Int]
go Int
count !Int
i [Int]
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
count = [Int] -> IO [Int]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int]
acc
      | Bool
otherwise = do
          nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
i
          if nt /= NodeDrawing
            then go count (i + 1) acc
            else do
              wid <- getWidgetId na i
              (x, y, w, h) <- getRect na i
              let rect = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
              mCustom <- lookupCustomDrawing ctx wid
              changed <- case mCustom of
                Just (CustomDrawingEntry Int
content CustomDrawBuild
build) -> do
                  cdc <- Context -> FontMetrics -> WidgetId -> IO CustomDrawContext
mkCustomDrawContext Context
ctx (Context -> FontMetrics
ctxFontMetrics Context
ctx) WidgetId
wid
                  refreshCustomDrawingOps ctx wid content rect cdc build
                Maybe CustomDrawingEntry
Nothing -> do
                  -- A versioned drawing rebuilds in paint once its version
                  -- changes, but the pixels it covered still need damage. An
                  -- unversioned one is cached by contract, so it stays put.
                  mDrawing <- Context -> WidgetId -> IO (Maybe DrawingEntry)
lookupDrawing Context
ctx WidgetId
wid
                  case mDrawing of
                    Just (DrawingEntry Int
content DrawingBuild
_) | Int
content Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 -> Context -> WidgetId -> Int -> Rect -> IO Bool
drawingOpsStale Context
ctx WidgetId
wid Int
content Rect
rect
                    Maybe DrawingEntry
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              go count (i + 1) (if changed then intKey wid : acc else acc)

-- | Whether the frame repaints the whole window rather than a clip.
needsFullDamage :: FrameSnapshot -> FrameDelta -> Bool
needsFullDamage :: FrameSnapshot -> FrameDelta -> Bool
needsFullDamage FrameSnapshot
snap FrameDelta
d =
  DamageRequest
ReqFull DamageRequest -> [DamageRequest] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FrameDelta -> [DamageRequest]
fdRequests FrameDelta
d
    Bool -> Bool -> Bool
|| Bool -> Bool
not (FrameDelta -> Bool
fdScrollOnly FrameDelta
d)
      Bool -> Bool -> Bool
&& ( FrameSnapshot -> Bool
fsWasDirty FrameSnapshot
snap
             Bool -> Bool -> Bool
|| WidgetStore -> WidgetStore -> Bool
mirrorStoresChanged (FrameSnapshot -> WidgetStore
fsStore FrameSnapshot
snap) (FrameDelta -> WidgetStore
fdStore FrameDelta
d)
             Bool -> Bool -> Bool
|| Bool
sizeChanged
             Bool -> Bool -> Bool
|| FrameDelta -> Bool
fdOverlayOpen FrameDelta
d
             Bool -> Bool -> Bool
|| FrameDelta -> Bool
fdModalFlip FrameDelta
d
             Bool -> Bool -> Bool
|| FrameDelta -> Bool
fdFloatingChanged FrameDelta
d
             Bool -> Bool -> Bool
|| FrameDelta -> Bool
fdWindowLive FrameDelta
d
             Bool -> Bool -> Bool
|| (Bool
orphanAnim Bool -> Bool -> Bool
&& FrameDelta -> Bool
fdAnimLive FrameDelta
d)
             Bool -> Bool -> Bool
|| Bool
keysChanged
             Bool -> Bool -> Bool
|| Bool
layoutSettle
         )
    Bool -> Bool -> Bool
|| (Bool
missingAnim Bool -> Bool -> Bool
&& FrameDelta -> Bool
fdAnimLive FrameDelta
d)
  where
    oldRects :: IntMap Rect
oldRects = FrameSnapshot -> IntMap Rect
fsRects FrameSnapshot
snap
    newRects :: IntMap Rect
newRects = FrameDelta -> IntMap Rect
fdRects FrameDelta
d
    oldSize :: Size
oldSize = FrameSnapshot -> Size
fsSize FrameSnapshot
snap
    sizeChanged :: Bool
sizeChanged = Size
oldSize Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
/= Float -> Float -> Size
Size Float
0 Float
0 Bool -> Bool -> Bool
&& Size
oldSize Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
/= FrameDelta -> Size
fdWinSize FrameDelta
d
    recentlyRectless :: Int -> Bool
recentlyRectless Int
k = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
k (FrameDelta -> IntMap Int
fdRectless FrameDelta
d) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
orphanEscalateFrames
    orphanAnim :: Bool
orphanAnim =
      (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
k -> Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember Int
k IntMap Rect
newRects Bool -> Bool -> Bool
&& Int -> Bool
recentlyRectless Int
k) (IntMap Animation -> [Int]
forall a. IntMap a -> [Int]
IM.keys (FrameDelta -> IntMap Animation
fdLiveAnims FrameDelta
d))
    -- A live animation whose key has no rect this frame or last is not
    -- clipped: the retain texture may never have shown it.
    missingAnim :: Bool
missingAnim =
      (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
        (\Int
k -> Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember Int
k IntMap Rect
oldRects Bool -> Bool -> Bool
&& Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember Int
k IntMap Rect
newRects Bool -> Bool -> Bool
&& Int -> Bool
recentlyRectless Int
k)
        (IntSet -> [Int]
IS.toList (FrameSnapshot -> IntSet
fsAnimKeys FrameSnapshot
snap IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntMap Animation -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet (FrameDelta -> IntMap Animation
fdLiveAnims FrameDelta
d)))
    keysChanged :: Bool
keysChanged =
      Bool -> Bool
not (IntMap Rect -> Bool
forall a. IntMap a -> Bool
IM.null IntMap Rect
oldRects)
        Bool -> Bool -> Bool
&& RectGroup -> Bool
rgAny (FrameDelta -> RectGroup
fdChurn FrameDelta
d)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (RectGroup -> Bool
rgInPanels (FrameDelta -> RectGroup
fdChurn FrameDelta
d))
    layoutSettle :: Bool
layoutSettle =
      Bool -> Bool
not (IntMap Rect -> Bool
forall a. IntMap a -> Bool
IM.null IntMap Rect
oldRects)
        Bool -> Bool -> Bool
&& RectGroup -> Bool
rgAny (FrameDelta -> RectGroup
fdSettledMoved FrameDelta
d)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (FrameDelta -> Bool
fdAnimLive FrameDelta
d)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (FrameDelta -> Bool
fdScrollChanged FrameDelta
d)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (RectGroup -> Bool
rgInPanels (FrameDelta -> RectGroup
fdSettledMoved FrameDelta
d))

-- | The clip covering everything that changed, or 'DamageFull' once that clip
-- exceeds half the window.
clipDamage :: Context -> FrameSnapshot -> FrameDelta -> IO Damage
clipDamage :: Context -> FrameSnapshot -> FrameDelta -> IO Damage
clipDamage Context
ctx FrameSnapshot
snap FrameDelta
d = do
  let oldRects :: IntMap Rect
oldRects = FrameSnapshot -> IntMap Rect
fsRects FrameSnapshot
snap
      newRects :: IntMap Rect
newRects = FrameDelta -> IntMap Rect
fdRects FrameDelta
d
      Size Float
winW Float
winH = FrameDelta -> Size
fdWinSize FrameDelta
d
      oldOf :: WidgetId -> Maybe Rect
oldOf WidgetId
wid
        | WidgetId
wid WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameSnapshot -> WidgetId
fsHot FrameSnapshot
snap = FrameSnapshot -> Maybe Rect
fsHotRect FrameSnapshot
snap
        | WidgetId
wid WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameSnapshot -> WidgetId
fsActive FrameSnapshot
snap = FrameSnapshot -> Maybe Rect
fsActiveRect FrameSnapshot
snap
        | WidgetId
wid WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameSnapshot -> WidgetId
fsFocus FrameSnapshot
snap = FrameSnapshot -> Maybe Rect
fsFocusRect FrameSnapshot
snap
        | Bool
otherwise = Maybe Rect
forall a. Maybe a
Nothing
  acc <- IO RectUnion
newRectUnion
  resolveDamageRequests ctx acc oldRects newRects (fdRequests d)
  -- Backdrop expansion covers interaction slop (hover/press halos) and
  -- explicit damage requests. Animation keys must not expand to their panel
  -- backdrop: an animated widget inside a large panel would damage the whole
  -- panel every frame, and once that union crosses half the window the frame
  -- degrades to DamageFull. The scissored replay redraws the backdrop fill
  -- inside the anim's own rect+slop, so no stale pixels remain.
  let addBackdrop Int
k =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Context -> Int -> IO (Maybe Int)
findNodeByKey Context
ctx Int
k
            IO (Maybe Int) -> (Maybe Int -> IO (Maybe Rect)) -> IO (Maybe Rect)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Rect)
-> (Int -> IO (Maybe Rect)) -> Maybe Int -> IO (Maybe Rect)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Rect
forall a. Maybe a
Nothing) (Context -> Int -> IO (Maybe Rect)
backdropRectFromNode Context
ctx)
            IO (Maybe Rect) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RectUnion -> Rect -> IO ()
addRect RectUnion
acc (Rect -> IO ()) -> (Rect -> Rect) -> Rect -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Rect -> Rect
clipRectToWindow Float
winW Float
winH)
      addInteraction WidgetId
wid = do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          newR <- Context -> WidgetId -> IO (Maybe Rect)
getPrevRect Context
ctx WidgetId
wid
          slop <- fromMaybe defaultDamageSlop <$> lookupCustomDamageSlop ctx wid
          let addSide = (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Rect
r -> Context -> Int -> Rect -> IO (Maybe Rect)
clipKeyRect Context
ctx (WidgetId -> Int
intKey WidgetId
wid) (Float -> Rect -> Rect
rectInflate Float
slop Rect
r) IO (Maybe Rect) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RectUnion -> Rect -> IO ()
addRect RectUnion
acc))
          addSide (oldOf wid)
          addSide newR
        Int -> IO ()
addBackdrop (WidgetId -> Int
intKey WidgetId
wid)
      -- A parked pointer must not re-damage its hot widget every frame: only
      -- an id change (hover in/out, press, focus move) or a rect move
      -- repaints. Unchanged interaction rects kept the steady state at
      -- DamageFull whenever the hot widget sat inside a panel whose backdrop
      -- covered over half the window.
      role WidgetId
oldW Maybe Rect
oldR WidgetId
newW = do
        newR <- Context -> WidgetId -> IO (Maybe Rect)
getPrevRect Context
ctx WidgetId
newW
        when (oldR /= newR) $ addInteraction oldW >> addInteraction newW
  role (fsHot snap) (fsHotRect snap) =<< getHotId ctx
  role (fsActive snap) (fsActiveRect snap) =<< readIORef (ctxActiveId ctx)
  role (fsFocus snap) (fsFocusRect snap) =<< readIORef (ctxFocusId ctx)
  forM_ (fdRequests d) $ \case
    ReqKey Int
k DamageBounds
_ -> Int -> IO ()
addBackdrop Int
k
    DamageRequest
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  when (fdScrollChanged d || fdPointsChanged d) $
    scrollOffsetDamage ctx acc (fsStore snap) (fdStore d)
  let addAnim Int
k =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Maybe Rect] -> (Maybe Rect -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
oldRects, Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
newRects] ((Maybe Rect -> IO ()) -> IO ()) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Rect
r -> Context -> Int -> Rect -> IO (Maybe Rect)
clipKeyRect Context
ctx Int
k (Float -> Rect -> Rect
rectInflate Float
defaultDamageSlop Rect
r) IO (Maybe Rect) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RectUnion -> Rect -> IO ()
addRect RectUnion
acc))
  IS.foldr (\Int
k IO ()
rest -> Int -> IO ()
addAnim Int
k IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rest) (pure ()) (fsAnimKeys snap)
  IM.foldrWithKey
    (\Int
k Animation
_ IO ()
rest -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> IntSet -> Bool
IS.member Int
k (FrameSnapshot -> IntSet
fsAnimKeys FrameSnapshot
snap)) (Int -> IO ()
addAnim Int
k) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rest)
    (pure ())
    (fdLiveAnims d)
  -- Same-key text changes that keep the rect (monospace counters, refreshed
  -- readouts) still repaint: rect-delta damage alone would leave them stale.
  -- New text keys inside floating panels also land here; outside panels the
  -- keysChanged predicate already forces full damage. updatePrevRects keeps
  -- last frame's map when no text changed.
  let addText Int
k =
        Maybe Rect -> (Rect -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
newRects) ((Rect -> IO ()) -> IO ()) -> (Rect -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Rect
r -> do
          -- An image that switched to another image keeps its size, so only
          -- its own rect repaints. A text change can reflow the enclosing
          -- scroller's content and reactivate/resize its chrome (thumb, caps)
          -- outside the text rect; damage the scroll node's full rect so the
          -- lane repaints.
          RectUnion -> Rect -> IO ()
addRect RectUnion
acc Rect
r
          mIdx <- Context -> Int -> IO (Maybe Int)
findNodeByKey Context
ctx Int
k
          isImage <- maybe (pure False) (fmap (== NodeImage) . getNodeType (ctxNodeArena ctx)) mIdx
          unless isImage $ scrollAncestorRect ctx k >>= mapM_ (addRect acc)
  unless (ptrEq (fdTexts d) (fsTexts snap)) $
    IM.foldrWithKey (\Int
k ()
_ IO ()
rest -> Int -> IO ()
addText Int
k IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rest) (pure ()) $
      IM.mergeWithKey
        (\Int
_ Text
new Text
old -> if Text
new Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
old then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
        (IM.map (const ()))
        (const IM.empty)
        (fdTexts d)
        (fsTexts snap)
  -- Drawings redrawn in place repaint their own rects, like a text change
  -- that keeps its rect.
  forM_ (fdRedrawn d) $ \Int
k ->
    Maybe Rect -> (Rect -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
newRects) ((Rect -> IO ()) -> IO ()) -> (Rect -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Rect
r -> Context -> Int -> Rect -> IO (Maybe Rect)
clipKeyRect Context
ctx Int
k Rect
r IO (Maybe Rect) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RectUnion -> Rect -> IO ()
addRect RectUnion
acc)
  unless (fdScrollOnly d) $ addGroup acc (fdSettledMoved d)
  -- Keys that left repaint as the current backdrop over their old rects. Keys
  -- that arrived must repaint inside their new rects too: the retain texture
  -- has never shown that content, and nothing else covers it (mirror writes
  -- escalate these frames to DamageFull, but layout-driven churn inside
  -- floating panels does not).
  addGroup acc (fdChurn d)
  -- Floating panels that moved, opened or closed repaint where they were and
  -- where they are.
  let addFloating IntMap Rect
other Int
k Rect
r IO ()
rest = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
other Maybe Rect -> Maybe Rect -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
r) (RectUnion -> Rect -> IO ()
addRect RectUnion
acc Rect
r) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rest
  IM.foldrWithKey (addFloating (fdFloatingRects d)) (pure ()) (fsFloatingRects snap)
  IM.foldrWithKey (addFloating (fsFloatingRects snap)) (pure ()) (fdFloatingRects d)
  base <- readRectUnion acc
  let clip = Float -> Float -> Rect -> Rect
clipRectToWindow Float
winW Float
winH Rect
base
      winArea = Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
winH
  -- A live animation with an empty clip is not DamageFull: its
  -- key was either scroll-clipped out of view (nothing visible
  -- changes; scrolling back in damages via the scroll delta) or
  -- rect-less, which missingAnim already promoted to full.
  pure $
    if winArea > 0 && rectArea clip > winArea * 0.5
      then DamageFull
      else DamageClip clip

resolveDamageRequests ::
  Context ->
  RectUnion ->
  IM.IntMap Rect ->
  IM.IntMap Rect ->
  [DamageRequest] ->
  IO ()
resolveDamageRequests :: Context
-> RectUnion
-> IntMap Rect
-> IntMap Rect
-> [DamageRequest]
-> IO ()
resolveDamageRequests Context
ctx RectUnion
acc IntMap Rect
oldRects IntMap Rect
newRects [DamageRequest]
reqs =
  [DamageRequest] -> (DamageRequest -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DamageRequest]
reqs ((DamageRequest -> IO ()) -> IO ())
-> (DamageRequest -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
    DamageRequest
ReqFull -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ReqRect Rect
r -> RectUnion -> Rect -> IO ()
addRect RectUnion
acc Rect
r
    ReqWidget WidgetId
wid DamageBounds
bounds -> Int -> DamageBounds -> IO ()
resolveKey (WidgetId -> Int
intKey WidgetId
wid) DamageBounds
bounds
    ReqKey Int
k DamageBounds
bounds -> Int -> DamageBounds -> IO ()
resolveKey Int
k DamageBounds
bounds
    ReqPeers [WidgetId]
wids DamageBounds
bounds -> [WidgetId] -> (WidgetId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [WidgetId]
wids ((WidgetId -> IO ()) -> IO ()) -> (WidgetId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WidgetId
wid -> Int -> DamageBounds -> IO ()
resolveKey (WidgetId -> Int
intKey WidgetId
wid) DamageBounds
bounds
  where
    resolveKey :: Int -> DamageBounds -> IO ()
resolveKey Int
k DamageBounds
bounds =
      [Maybe Rect] -> (Maybe Rect -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
oldRects, Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Rect
newRects] ((Maybe Rect -> IO ()) -> IO ()) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Rect -> IO ()) -> Maybe Rect -> IO ())
-> (Rect -> IO ()) -> Maybe Rect -> IO ()
forall a b. (a -> b) -> a -> b
$ \Rect
r -> do
          clipped <- Context -> Int -> Rect -> IO Rect
clipDeltaToScrollViewport Context
ctx Int
k (DamageBounds -> Rect -> Rect
resolveDamageRect DamageBounds
bounds Rect
r)
          when (rectNonEmpty clipped) $ addRect acc clipped

-- | A running union of rects, as @x0, y0, x1, y1@ followed by how many of
-- them lie outside every floating panel. The bounds start inverted, so the
-- first rect sets them and an empty union reads back as the zero rect.
newtype RectUnion = RectUnion (MutablePrimArray RealWorld Float)

newRectUnion :: IO RectUnion
newRectUnion :: IO RectUnion
newRectUnion = do
  a <- Int -> IO (MutablePrimArray (PrimState IO) Float)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
5
  writePrimArray a 0 infinity
  writePrimArray a 1 infinity
  writePrimArray a 2 (-infinity)
  writePrimArray a 3 (-infinity)
  writePrimArray a 4 0
  pure (RectUnion a)
  where
    infinity :: Float
infinity = Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0

{-# INLINE addRect #-}
addRect :: RectUnion -> Rect -> IO ()
addRect :: RectUnion -> Rect -> IO ()
addRect (RectUnion MutablePrimArray RealWorld Float
a) (Rect Float
x Float
y Float
w Float
h) = do
  x0 <- 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
a Int
0
  y0 <- readPrimArray a 1
  x1 <- readPrimArray a 2
  y1 <- readPrimArray a 3
  writePrimArray a 0 (min x0 x)
  writePrimArray a 1 (min y0 y)
  writePrimArray a 2 (max x1 (x + w))
  writePrimArray a 3 (max y1 (y + h))

readRectUnion :: RectUnion -> IO Rect
readRectUnion :: RectUnion -> IO Rect
readRectUnion (RectUnion MutablePrimArray RealWorld Float
a) = do
  x0 <- 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
a Int
0
  y0 <- readPrimArray a 1
  x1 <- readPrimArray a 2
  y1 <- readPrimArray a 3
  pure $! if x0 > x1 then Rect 0 0 0 0 else Rect x0 y0 (x1 - x0) (y1 - y0)

-- | A set of rects reduced to what damage needs from it.
data RectGroup = RectGroup
  { RectGroup -> Bool
rgAny :: !Bool
  , RectGroup -> Bool
rgInPanels :: !Bool
  -- ^ Some floating panel fully contains each rect; False for an empty group.
  , RectGroup -> Rect
rgBounds :: !Rect
  }

addGroup :: RectUnion -> RectGroup -> IO ()
addGroup :: RectUnion -> RectGroup -> IO ()
addGroup RectUnion
acc RectGroup
g = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RectGroup -> Bool
rgAny RectGroup
g) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RectUnion -> Rect -> IO ()
addRect RectUnion
acc (RectGroup -> Rect
rgBounds RectGroup
g)

-- | One pass over the keys whose rect changed, reduced to the settled moves
-- (clipped to scroll viewports, above 'layoutSettleMinArea') and the keys
-- that left or joined the arena.
rectDeltas :: Context -> [Rect] -> IM.IntMap Rect -> IM.IntMap Rect -> IO (RectGroup, RectGroup)
rectDeltas :: Context
-> [Rect]
-> IntMap Rect
-> IntMap Rect
-> IO (RectGroup, RectGroup)
rectDeltas Context
ctx [Rect]
panelRects IntMap Rect
old IntMap Rect
new
  | IntMap Rect -> IntMap Rect -> Bool
forall a. a -> a -> Bool
ptrEq IntMap Rect
old IntMap Rect
new = (RectGroup, RectGroup) -> IO (RectGroup, RectGroup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RectGroup
emptyGroup, RectGroup
emptyGroup)
  | Bool
otherwise = do
      settled <- IO RectUnion
newRectUnion
      churn <- newRectUnion
      let note acc :: RectUnion
acc@(RectUnion MutablePrimArray RealWorld Float
a) Rect
r = do
            RectUnion -> Rect -> IO ()
addRect RectUnion
acc Rect
r
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Rect -> Bool) -> [Rect] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Rect -> Rect -> Bool
rectFullyInside Rect
r) [Rect]
panelRects) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              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
a Int
4 IO Float -> (Float -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutablePrimArray (PrimState IO) Float -> Int -> Float -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
a Int
4 (Float -> IO ()) -> (Float -> Float) -> Float -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1)
      IM.foldrWithKey
        ( \Int
k Rect
r IO ()
rest -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rect -> Bool
rectNonEmpty Rect
r) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember Int
k IntMap Rect
new Bool -> Bool -> Bool
|| Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember Int
k IntMap Rect
old) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RectUnion -> Rect -> IO ()
note RectUnion
churn Rect
r
              clipped <- Context -> Int -> Rect -> IO Rect
clipDeltaToScrollViewport Context
ctx Int
k Rect
r
              when (rectArea clipped >= layoutSettleMinArea) $ note settled clipped
            IO ()
rest
        )
        (pure ())
        (IM.mergeWithKey (\Int
_ Rect
a Rect
b -> if Rect
a Rect -> Rect -> Bool
forall a. Eq a => a -> a -> Bool
/= Rect
b then Rect -> Maybe Rect
forall a. a -> Maybe a
Just (Rect -> Rect -> Rect
rectUnion Rect
a Rect
b) else Maybe Rect
forall a. Maybe a
Nothing) id id old new)
      (,) <$> freeze settled <*> freeze churn
  where
    emptyGroup :: RectGroup
emptyGroup = Bool -> Bool -> Rect -> RectGroup
RectGroup Bool
False Bool
False (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0)
    freeze :: RectUnion -> IO RectGroup
freeze acc :: RectUnion
acc@(RectUnion MutablePrimArray RealWorld Float
a) = do
      bounds <- RectUnion -> IO Rect
readRectUnion RectUnion
acc
      x0 <- readPrimArray a 0
      x1 <- readPrimArray a 2
      outside <- readPrimArray a 4
      let !present = Float
x0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
x1
      pure (RectGroup present (present && not (null panelRects) && outside == 0) bounds)

clipDeltaToScrollViewport :: Context -> Int -> Rect -> IO Rect
clipDeltaToScrollViewport :: Context -> Int -> Rect -> IO Rect
clipDeltaToScrollViewport Context
ctx Int
k Rect
r = do
  Context -> Int -> IO (Maybe Int)
findNodeByKey Context
ctx Int
k IO (Maybe Int) -> (Maybe Int -> IO Rect) -> IO Rect
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Int
Nothing -> Rect -> IO Rect
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rect
r
    Just Int
idx -> do
      mClip <- NodeArena -> Int -> IO (Maybe Rect)
getClipRect (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      pure $
        case mClip of
          Maybe Rect
Nothing -> Rect
r
          Just Rect
clip -> Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0) (Rect -> Rect -> Maybe Rect
rectIntersect Rect
r Rect
clip)

clipRectToWindow :: Float -> Float -> Rect -> Rect
clipRectToWindow :: Float -> Float -> Rect -> Rect
clipRectToWindow Float
winW Float
winH Rect
r =
  Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0) (Rect -> Rect -> Maybe Rect
rectIntersect Rect
r (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
winW Float
winH))

clipKeyRect :: Context -> Int -> Rect -> IO (Maybe Rect)
clipKeyRect :: Context -> Int -> Rect -> IO (Maybe Rect)
clipKeyRect Context
ctx Int
k Rect
r
  | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
r)
  | Bool
otherwise = do
      clipped <- Context -> Int -> Rect -> IO Rect
clipDeltaToScrollViewport Context
ctx Int
k Rect
r
      pure (if rectNonEmpty clipped then Just clipped else Nothing)

-- | Rect of the nearest scroll-container ancestor of a keyed node, covering
-- the content viewport and the scrollbar lane its chrome paints in. The walk
-- stops at the first scroll node even when its rect is empty.
scrollAncestorRect :: Context -> Int -> IO (Maybe Rect)
scrollAncestorRect :: Context -> Int -> IO (Maybe Rect)
scrollAncestorRect Context
ctx Int
k =
  Context -> Int -> IO (Maybe Int)
findNodeByKey Context
ctx Int
k IO (Maybe Int) -> (Maybe Int -> IO (Maybe Rect)) -> IO (Maybe Rect)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Rect)
-> (Int -> IO (Maybe Rect)) -> Maybe Int -> IO (Maybe Rect)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Rect
forall a. Maybe a
Nothing) ((Maybe (Maybe Rect) -> Maybe Rect)
-> IO (Maybe (Maybe Rect)) -> IO (Maybe Rect)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe Rect) -> Maybe Rect
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe Rect)) -> IO (Maybe Rect))
-> (Int -> IO (Maybe (Maybe Rect))) -> Int -> IO (Maybe Rect)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IO (Maybe (Maybe Rect)))
-> NodeArena -> Int -> IO (Maybe (Maybe Rect))
forall a. (Int -> IO (Maybe a)) -> NodeArena -> Int -> IO (Maybe a)
walkAncestors Int -> IO (Maybe (Maybe Rect))
step NodeArena
na)
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    step :: Int -> IO (Maybe (Maybe Rect))
step Int
i = do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
i
      if isScrollNode nt
        then Just <$> getNonzeroRect na i
        else pure Nothing

scrollOffsetDamage :: Context -> RectUnion -> WidgetStore -> WidgetStore -> IO ()
scrollOffsetDamage :: Context -> RectUnion -> WidgetStore -> WidgetStore -> IO ()
scrollOffsetDamage Context
ctx RectUnion
acc WidgetStore
oldStore WidgetStore
newStore =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IntMap () -> Bool
forall a. IntMap a -> Bool
IM.null IntMap ()
changedKeys) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Every store key that holds a scroll node's offset, mapped to the first
    -- such node. Built once, only on frames where an offset changed.
    owners <- NodeArena
-> (IntMap Int -> Int -> IO (IntMap Int))
-> IntMap Int
-> IO (IntMap Int)
forall a. NodeArena -> (a -> Int -> IO a) -> a -> IO a
foldNodeRevM NodeArena
na IntMap Int -> Int -> IO (IntMap Int)
addOwner IntMap Int
forall a. IntMap a
IM.empty
    IM.foldrWithKey
      ( \Int
k ()
_ IO ()
rest -> do
          Maybe Int -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap Int
owners) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
idx -> do
            -- The scroll node's rect covers the content viewport AND the
            -- scrollbar lane: offset changes move the thumb, which paints
            -- outside the content clip.
            NodeArena -> Int -> IO (Maybe Rect)
getNonzeroRect NodeArena
na Int
idx IO (Maybe Rect) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RectUnion -> Rect -> IO ()
addRect RectUnion
acc)
            Context -> Int -> IO (Maybe Rect)
floatingAncestorRect Context
ctx Int
idx IO (Maybe Rect) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RectUnion -> Rect -> IO ()
addRect RectUnion
acc)
          IO ()
rest
      )
      (pure ())
      changedKeys
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    -- Floating-pane offsets live in storeFloat; wheel/keyboard offsets
    -- live under the SlotTextAreaScroll slot in storePoint. Both move the
    -- scroller's content and its chrome. New or removed float offsets only
    -- count when nonzero.
    changedKeys :: IntMap ()
changedKeys =
      (IntMap Float -> IntMap ())
-> IntMap Float -> IntMap Float -> IntMap ()
forall a.
Eq a =>
(IntMap a -> IntMap ()) -> IntMap a -> IntMap a -> IntMap ()
changedKeysWith ((Float -> ()) -> IntMap Float -> IntMap ()
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Float -> ()
forall a b. a -> b -> a
const ()) (IntMap Float -> IntMap ())
-> (IntMap Float -> IntMap Float) -> IntMap Float -> IntMap ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Bool) -> IntMap Float -> IntMap Float
forall a. (a -> Bool) -> IntMap a -> IntMap a
IM.filter (Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
0)) (WidgetStore -> IntMap Float
storeFloat WidgetStore
oldStore) (WidgetStore -> IntMap Float
storeFloat WidgetStore
newStore)
        IntMap () -> IntMap () -> IntMap ()
forall a. IntMap a -> IntMap a -> IntMap a
`IM.union` (IntMap (Float, Float) -> IntMap ())
-> IntMap (Float, Float) -> IntMap (Float, Float) -> IntMap ()
forall a.
Eq a =>
(IntMap a -> IntMap ()) -> IntMap a -> IntMap a -> IntMap ()
changedKeysWith (((Float, Float) -> ()) -> IntMap (Float, Float) -> IntMap ()
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> (Float, Float) -> ()
forall a b. a -> b -> a
const ())) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
oldStore) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
newStore)
    changedKeysWith :: Eq a => (IM.IntMap a -> IM.IntMap ()) -> IM.IntMap a -> IM.IntMap a -> IM.IntMap ()
    changedKeysWith :: forall a.
Eq a =>
(IntMap a -> IntMap ()) -> IntMap a -> IntMap a -> IntMap ()
changedKeysWith IntMap a -> IntMap ()
oneSided IntMap a
old IntMap a
new =
      (Int -> a -> a -> Maybe ())
-> (IntMap a -> IntMap ())
-> (IntMap a -> IntMap ())
-> IntMap a
-> IntMap a
-> IntMap ()
forall a b c.
(Int -> a -> b -> Maybe c)
-> (IntMap a -> IntMap c)
-> (IntMap b -> IntMap c)
-> IntMap a
-> IntMap b
-> IntMap c
IM.mergeWithKey (\Int
_ a
a a
b -> if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing) IntMap a -> IntMap ()
oneSided IntMap a -> IntMap ()
oneSided IntMap a
old IntMap a
new
    addOwner :: IntMap Int -> Int -> IO (IntMap Int)
addOwner IntMap Int
m Int
idx = do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
      if not (isScrollNode nt)
        then pure m
        else do
          wid <- getWidgetId na idx
          let widKey = WidgetId -> Int
intKey WidgetId
wid
          pure $
            IM.insert widKey idx $
              IM.insert (slotKey SlotScrollCross widKey) idx $
                IM.insert (slotKey SlotTextAreaScroll widKey) idx m

floatingAncestorRect :: Context -> Int -> IO (Maybe Rect)
floatingAncestorRect :: Context -> Int -> IO (Maybe Rect)
floatingAncestorRect Context
ctx Int
idx =
  (Int -> IO (Maybe Rect)) -> NodeArena -> Int -> IO (Maybe Rect)
forall a. (Int -> IO (Maybe a)) -> NodeArena -> Int -> IO (Maybe a)
walkAncestors Int -> IO (Maybe Rect)
check (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  where
    check :: Int -> IO (Maybe Rect)
check Int
i = do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) Int
i
      if isFloatingNode nt
        then getNonzeroRect (ctxNodeArena ctx) i
        else pure Nothing