-- | Per-widget drawing registrations and the caches derived from them.
module NanoUI.Context.Drawing
  ( registerPopupConfig
  , lookupPopupConfig
  , registerDrawing
  , lookupDrawing
  , cachedDrawingOps
  , cachedWidgetLayout
  , lookupDrawFitEnvelope
  , pruneDrawOpCache
  , registerCustomDrawing
  , lookupCustomDrawing
  , cachedCustomDrawingOps
  , refreshCustomDrawingOps
  , drawingOpsStale
  , registerCustomMeasure
  , lookupCustomMeasure
  , registerCustomCursor
  , lookupCustomCursor
  , registerCustomDamageSlop
  , lookupCustomDamageSlop
  , resetDrawingScopeCache
  , hasCustomLayoutInputs
  ) where

import Data.IORef (modifyIORef', readIORef)
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IM
import Data.Primitive.SmallArray (SmallArray, mapSmallArray')

import NanoUI.Context.Animation (isAnimatingKey)
import NanoUI.Context.Types
  ( Context (..)
  , CustomDrawBuild
  , CustomDrawContext (..)
  , CustomDrawOpCacheEntry (..)
  , CustomDrawingEntry (..)
  , CustomMeasureFn
  , DrawFitCache (..)
  , DrawOpCacheEntry (..)
  , DrawingCacheState (..)
  , DrawingEntry (..)
  , PopupConfig (..)
  , intKey
  )
import NanoUI.Draw (DrawOp, DrawingBuild, shiftDrawOp)
import NanoUI.Id (WidgetId)
import NanoUI.Input (UiCursorKind)
import NanoUI.Style (Layout)
import NanoUI.Types (PopupAnchor, PopupPlacement, Rect (..), rectH, rectW)

{-# INLINE lookupIn #-}
lookupIn :: (DrawingCacheState -> IntMap a) -> Context -> WidgetId -> IO (Maybe a)
lookupIn :: forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap a
field Context
ctx WidgetId
wid = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup (WidgetId -> Int
intKey WidgetId
wid) (IntMap a -> Maybe a)
-> (DrawingCacheState -> IntMap a) -> DrawingCacheState -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawingCacheState -> IntMap a
field (DrawingCacheState -> Maybe a)
-> IO DrawingCacheState -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef DrawingCacheState -> IO DrawingCacheState
forall a. IORef a -> IO a
readIORef (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx)

{-# INLINE registerIn #-}
registerIn ::
  (DrawingCacheState -> IntMap a) ->
  (IntMap a -> DrawingCacheState -> DrawingCacheState) ->
  Context ->
  WidgetId ->
  a ->
  IO ()
registerIn :: forall a.
(DrawingCacheState -> IntMap a)
-> (IntMap a -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> a
-> IO ()
registerIn DrawingCacheState -> IntMap a
field IntMap a -> DrawingCacheState -> DrawingCacheState
setField Context
ctx WidgetId
wid a
v =
  IORef DrawingCacheState
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx) ((DrawingCacheState -> DrawingCacheState) -> IO ())
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DrawingCacheState
dc ->
    IntMap a -> DrawingCacheState -> DrawingCacheState
setField (Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (WidgetId -> Int
intKey WidgetId
wid) a
v (DrawingCacheState -> IntMap a
field DrawingCacheState
dc)) DrawingCacheState
dc

{-# INLINE registerPopupConfig #-}
registerPopupConfig :: Context -> WidgetId -> PopupAnchor -> PopupPlacement -> Float -> IO ()
registerPopupConfig :: Context
-> WidgetId -> PopupAnchor -> PopupPlacement -> Float -> IO ()
registerPopupConfig Context
ctx WidgetId
wid PopupAnchor
anchor PopupPlacement
placement Float
offset =
  (DrawingCacheState -> IntMap PopupConfig)
-> (IntMap PopupConfig -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> PopupConfig
-> IO ()
forall a.
(DrawingCacheState -> IntMap a)
-> (IntMap a -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> a
-> IO ()
registerIn DrawingCacheState -> IntMap PopupConfig
dcsPopupConfigs (\IntMap PopupConfig
m DrawingCacheState
dc -> DrawingCacheState
dc {dcsPopupConfigs = m}) Context
ctx WidgetId
wid (PopupAnchor -> PopupPlacement -> Float -> PopupConfig
PopupConfig PopupAnchor
anchor PopupPlacement
placement Float
offset)

{-# INLINE lookupPopupConfig #-}
lookupPopupConfig :: Context -> WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float))
lookupPopupConfig :: Context
-> WidgetId -> IO (Maybe (PopupAnchor, PopupPlacement, Float))
lookupPopupConfig Context
ctx WidgetId
wid =
  (PopupConfig -> (PopupAnchor, PopupPlacement, Float))
-> Maybe PopupConfig -> Maybe (PopupAnchor, PopupPlacement, Float)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PopupConfig PopupAnchor
anchor PopupPlacement
placement Float
offset) -> (PopupAnchor
anchor, PopupPlacement
placement, Float
offset))
    (Maybe PopupConfig -> Maybe (PopupAnchor, PopupPlacement, Float))
-> IO (Maybe PopupConfig)
-> IO (Maybe (PopupAnchor, PopupPlacement, Float))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DrawingCacheState -> IntMap PopupConfig)
-> Context -> WidgetId -> IO (Maybe PopupConfig)
forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap PopupConfig
dcsPopupConfigs Context
ctx WidgetId
wid

{-# INLINE registerDrawing #-}
registerDrawing :: Context -> WidgetId -> Int -> DrawingBuild -> IO ()
registerDrawing :: Context -> WidgetId -> Int -> DrawingBuild -> IO ()
registerDrawing Context
ctx WidgetId
wid Int
content DrawingBuild
build =
  (DrawingCacheState -> IntMap DrawingEntry)
-> (IntMap DrawingEntry -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> DrawingEntry
-> IO ()
forall a.
(DrawingCacheState -> IntMap a)
-> (IntMap a -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> a
-> IO ()
registerIn DrawingCacheState -> IntMap DrawingEntry
dcsDrawings (\IntMap DrawingEntry
m DrawingCacheState
dc -> DrawingCacheState
dc {dcsDrawings = m}) Context
ctx WidgetId
wid (Int -> DrawingBuild -> DrawingEntry
DrawingEntry Int
content DrawingBuild
build)

{-# INLINE lookupDrawing #-}
lookupDrawing :: Context -> WidgetId -> IO (Maybe DrawingEntry)
lookupDrawing :: Context -> WidgetId -> IO (Maybe DrawingEntry)
lookupDrawing = (DrawingCacheState -> IntMap DrawingEntry)
-> Context -> WidgetId -> IO (Maybe DrawingEntry)
forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap DrawingEntry
dcsDrawings

-- | One draw-op cache step. @hit@ holds the bounds and ops of an entry whose
-- key still matches. A same-size hit is reused, translated if the widget
-- moved; a miss or a resize uses @rebuilt@. Ops that differ from the entry are
-- written back with @store@.
serveOps ::
  Maybe (Rect, SmallArray DrawOp) ->
  Rect ->
  SmallArray DrawOp ->
  (SmallArray DrawOp -> IO ()) ->
  IO (SmallArray DrawOp)
serveOps :: Maybe (Rect, SmallArray DrawOp)
-> Rect
-> SmallArray DrawOp
-> (SmallArray DrawOp -> IO ())
-> IO (SmallArray DrawOp)
serveOps Maybe (Rect, SmallArray DrawOp)
hit Rect
rect SmallArray DrawOp
rebuilt SmallArray DrawOp -> IO ()
store =
  case Maybe (Rect, SmallArray DrawOp)
hit of
    Just (Rect
r, SmallArray DrawOp
ops)
      | Rect -> Float
rectW Rect
r Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Float
rectW Rect
rect Bool -> Bool -> Bool
&& Rect -> Float
rectH Rect
r Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Float
rectH Rect
rect ->
          if Rect -> Float
rectX Rect
r Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Float
rectX Rect
rect Bool -> Bool -> Bool
&& Rect -> Float
rectY Rect
r Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Float
rectY Rect
rect
            then SmallArray DrawOp -> IO (SmallArray DrawOp)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray DrawOp
ops
            else SmallArray DrawOp -> IO (SmallArray DrawOp)
keep ((DrawOp -> DrawOp) -> SmallArray DrawOp -> SmallArray DrawOp
forall a b. (a -> b) -> SmallArray a -> SmallArray b
mapSmallArray' (Float -> Float -> DrawOp -> DrawOp
shiftDrawOp (Rect -> Float
rectX Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
- Rect -> Float
rectX Rect
r) (Rect -> Float
rectY Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
- Rect -> Float
rectY Rect
r)) SmallArray DrawOp
ops)
    Maybe (Rect, SmallArray DrawOp)
_ -> SmallArray DrawOp -> IO (SmallArray DrawOp)
keep SmallArray DrawOp
rebuilt
  where
    keep :: SmallArray DrawOp -> IO (SmallArray DrawOp)
keep SmallArray DrawOp
ops = SmallArray DrawOp -> IO ()
store SmallArray DrawOp
ops IO () -> IO (SmallArray DrawOp) -> IO (SmallArray DrawOp)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SmallArray DrawOp -> IO (SmallArray DrawOp)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray DrawOp
ops

-- | Rebuild draw ops when the content version or width/height change. A move
-- only translates. An unversioned drawing (content 0) additionally drops its
-- cache while the widget is animating, since it has no other invalidation
-- signal; versioned drawings are invalidated by their content key alone.
cachedDrawingOps :: Context -> WidgetId -> Int -> Rect -> DrawingBuild -> IO (SmallArray DrawOp)
cachedDrawingOps :: Context
-> WidgetId
-> Int
-> Rect
-> DrawingBuild
-> IO (SmallArray DrawOp)
cachedDrawingOps Context
ctx WidgetId
wid Int
content Rect
rect DrawingBuild
build = do
  let k :: Int
k = WidgetId -> Int
intKey WidgetId
wid
  animated <-
    if Int
content Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then Context -> Int -> IO Bool
isAnimatingKey Context
ctx Int
k
      else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  cached <- IM.lookup k . dcsDrawOpCache <$> readIORef (ctxDrawingCache ctx)
  let hit = case Maybe DrawOpCacheEntry
cached of
        Just DrawOpCacheEntry {doeContent :: DrawOpCacheEntry -> Int
doeContent = Int
c, doeBounds :: DrawOpCacheEntry -> Rect
doeBounds = Rect
r, doeOps :: DrawOpCacheEntry -> SmallArray DrawOp
doeOps = SmallArray DrawOp
ops}
          | Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
content Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
animated -> (Rect, SmallArray DrawOp) -> Maybe (Rect, SmallArray DrawOp)
forall a. a -> Maybe a
Just (Rect
r, SmallArray DrawOp
ops)
        Maybe DrawOpCacheEntry
_ -> Maybe (Rect, SmallArray DrawOp)
forall a. Maybe a
Nothing
  serveOps hit rect (build rect) $ \SmallArray DrawOp
ops ->
    IORef DrawingCacheState
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx) ((DrawingCacheState -> DrawingCacheState) -> IO ())
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DrawingCacheState
s ->
      DrawingCacheState
s {dcsDrawOpCache = IM.insert k (DrawOpCacheEntry content rect ops) (dcsDrawOpCache s)}

-- | Reuse a derived layout while envelope, font, content key, and caller layout match.
cachedWidgetLayout ::
  Context ->
  WidgetId ->
  Double ->
  Double ->
  Float ->
  Int ->
  Layout ->
  IO Layout ->
  IO Layout
cachedWidgetLayout :: Context
-> WidgetId
-> Double
-> Double
-> Float
-> Int
-> Layout
-> IO Layout
-> IO Layout
cachedWidgetLayout Context
ctx WidgetId
wid Double
dw Double
dh Float
lh Int
content Layout
incoming IO Layout
compute = do
  let k :: Int
k = WidgetId -> Int
intKey WidgetId
wid
  dc <- IORef DrawingCacheState -> IO DrawingCacheState
forall a. IORef a -> IO a
readIORef (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx)
  case IM.lookup k (dcsDrawFitCache dc) of
    Just DrawFitCache
e
      | DrawFitCache -> Double
dfcDw DrawFitCache
e Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
dw
          Bool -> Bool -> Bool
&& DrawFitCache -> Double
dfcDh DrawFitCache
e Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
dh
          Bool -> Bool -> Bool
&& DrawFitCache -> Float
dfcLh DrawFitCache
e Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
lh
          Bool -> Bool -> Bool
&& DrawFitCache -> Int
dfcContent DrawFitCache
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
content
          Bool -> Bool -> Bool
&& DrawFitCache -> Layout
dfcIn DrawFitCache
e Layout -> Layout -> Bool
forall a. Eq a => a -> a -> Bool
== Layout
incoming ->
          Layout -> IO Layout
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DrawFitCache -> Layout
dfcOut DrawFitCache
e)
    Maybe DrawFitCache
_ -> do
      out <- IO Layout
compute
      modifyIORef' (ctxDrawingCache ctx) $ \DrawingCacheState
s ->
        DrawingCacheState
s { dcsDrawFitCache = IM.insert k (DrawFitCache dw dh lh content incoming out) (dcsDrawFitCache s)
          , dcsDrawOpCache = IM.delete k (dcsDrawOpCache s)
          }
      pure out

lookupDrawFitEnvelope ::
  Context ->
  WidgetId ->
  Float ->
  Int ->
  Layout ->
  IO (Maybe (Double, Double))
lookupDrawFitEnvelope :: Context
-> WidgetId
-> Float
-> Int
-> Layout
-> IO (Maybe (Double, Double))
lookupDrawFitEnvelope Context
ctx WidgetId
wid Float
lh Int
content Layout
incoming = do
  cached <- (DrawingCacheState -> IntMap DrawFitCache)
-> Context -> WidgetId -> IO (Maybe DrawFitCache)
forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap DrawFitCache
dcsDrawFitCache Context
ctx WidgetId
wid
  pure $ case cached of
    Just DrawFitCache
e
      | DrawFitCache -> Float
dfcLh DrawFitCache
e Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
lh
          Bool -> Bool -> Bool
&& DrawFitCache -> Int
dfcContent DrawFitCache
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
content
          Bool -> Bool -> Bool
&& DrawFitCache -> Layout
dfcIn DrawFitCache
e Layout -> Layout -> Bool
forall a. Eq a => a -> a -> Bool
== Layout
incoming ->
          (Double, Double) -> Maybe (Double, Double)
forall a. a -> Maybe a
Just (DrawFitCache -> Double
dfcDw DrawFitCache
e, DrawFitCache -> Double
dfcDh DrawFitCache
e)
    Maybe DrawFitCache
_ -> Maybe (Double, Double)
forall a. Maybe a
Nothing

-- | Drop cached ops for drawings that did not rebuild this frame.
pruneDrawOpCache :: Context -> IO ()
pruneDrawOpCache :: Context -> IO ()
pruneDrawOpCache Context
ctx =
  IORef DrawingCacheState
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx) ((DrawingCacheState -> DrawingCacheState) -> IO ())
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DrawingCacheState
dc ->
    let live :: IntMap DrawingEntry
live = DrawingCacheState -> IntMap DrawingEntry
dcsDrawings DrawingCacheState
dc
        customLive :: IntMap CustomDrawingEntry
customLive = DrawingCacheState -> IntMap CustomDrawingEntry
dcsCustomDrawings DrawingCacheState
dc
     in DrawingCacheState
dc
          { dcsDrawOpCache = dcsDrawOpCache dc `IM.intersection` live
          , dcsCustomDrawOpCache = dcsCustomDrawOpCache dc `IM.intersection` customLive
          , dcsDrawFitCache = dcsDrawFitCache dc `IM.intersection` live
          }

{-# INLINE registerCustomDrawing #-}
registerCustomDrawing :: Context -> WidgetId -> Int -> CustomDrawBuild -> IO ()
registerCustomDrawing :: Context -> WidgetId -> Int -> CustomDrawBuild -> IO ()
registerCustomDrawing Context
ctx WidgetId
wid Int
content CustomDrawBuild
build =
  (DrawingCacheState -> IntMap CustomDrawingEntry)
-> (IntMap CustomDrawingEntry
    -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> CustomDrawingEntry
-> IO ()
forall a.
(DrawingCacheState -> IntMap a)
-> (IntMap a -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> a
-> IO ()
registerIn DrawingCacheState -> IntMap CustomDrawingEntry
dcsCustomDrawings (\IntMap CustomDrawingEntry
m DrawingCacheState
dc -> DrawingCacheState
dc {dcsCustomDrawings = m}) Context
ctx WidgetId
wid (Int -> CustomDrawBuild -> CustomDrawingEntry
CustomDrawingEntry Int
content CustomDrawBuild
build)

{-# INLINE lookupCustomDrawing #-}
lookupCustomDrawing :: Context -> WidgetId -> IO (Maybe CustomDrawingEntry)
lookupCustomDrawing :: Context -> WidgetId -> IO (Maybe CustomDrawingEntry)
lookupCustomDrawing = (DrawingCacheState -> IntMap CustomDrawingEntry)
-> Context -> WidgetId -> IO (Maybe CustomDrawingEntry)
forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap CustomDrawingEntry
dcsCustomDrawings

-- | Whether a cache entry was built from these inputs, leaving aside where the
-- widget sits: ops built at another origin translate rather than rebuild.
{-# INLINE customEntryMatches #-}
customEntryMatches :: CustomDrawOpCacheEntry -> Int -> Rect -> CustomDrawContext -> Int -> Bool
customEntryMatches :: CustomDrawOpCacheEntry
-> Int -> Rect -> CustomDrawContext -> Int -> Bool
customEntryMatches CustomDrawOpCacheEntry
e Int
content Rect
rect CustomDrawContext
cdc Int
gen =
  CustomDrawOpCacheEntry -> Int
cdeContent CustomDrawOpCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
content
    Bool -> Bool -> Bool
&& Rect -> Float
rectW (CustomDrawOpCacheEntry -> Rect
cdeBounds CustomDrawOpCacheEntry
e) Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Float
rectW Rect
rect
    Bool -> Bool -> Bool
&& Rect -> Float
rectH (CustomDrawOpCacheEntry -> Rect
cdeBounds CustomDrawOpCacheEntry
e) Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Rect -> Float
rectH Rect
rect
    Bool -> Bool -> Bool
&& CustomDrawOpCacheEntry -> Bool
cdeHovered CustomDrawOpCacheEntry
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== CustomDrawContext -> Bool
cdcHovered CustomDrawContext
cdc
    Bool -> Bool -> Bool
&& CustomDrawOpCacheEntry -> Bool
cdePressed CustomDrawOpCacheEntry
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== CustomDrawContext -> Bool
cdcPressed CustomDrawContext
cdc
    Bool -> Bool -> Bool
&& CustomDrawOpCacheEntry -> Bool
cdeFocused CustomDrawOpCacheEntry
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== CustomDrawContext -> Bool
cdcFocused CustomDrawContext
cdc
    Bool -> Bool -> Bool
&& CustomDrawOpCacheEntry -> Bool
cdeDisabled CustomDrawOpCacheEntry
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== CustomDrawContext -> Bool
cdcDisabled CustomDrawContext
cdc
    Bool -> Bool -> Bool
&& CustomDrawOpCacheEntry -> Int
cdeGen CustomDrawOpCacheEntry
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
gen

-- | Draw ops for a custom widget's paint: the ops 'refreshCustomDrawingOps'
-- settled on this frame while every input still matches, translated if the
-- widget only moved, else a fresh build.
cachedCustomDrawingOps ::
  Context ->
  WidgetId ->
  Int ->
  Rect ->
  CustomDrawContext ->
  CustomDrawBuild ->
  IO (SmallArray DrawOp)
cachedCustomDrawingOps :: Context
-> WidgetId
-> Int
-> Rect
-> CustomDrawContext
-> CustomDrawBuild
-> IO (SmallArray DrawOp)
cachedCustomDrawingOps Context
ctx WidgetId
wid Int
content Rect
rect CustomDrawContext
cdc CustomDrawBuild
build = do
  let k :: Int
k = WidgetId -> Int
intKey WidgetId
wid
  gen <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Context -> IORef Int
ctxMetricGen Context
ctx)
  cached <- IM.lookup k . dcsCustomDrawOpCache <$> readIORef (ctxDrawingCache ctx)
  let hit = case Maybe CustomDrawOpCacheEntry
cached of
        Just CustomDrawOpCacheEntry
e | CustomDrawOpCacheEntry
-> Int -> Rect -> CustomDrawContext -> Int -> Bool
customEntryMatches CustomDrawOpCacheEntry
e Int
content Rect
rect CustomDrawContext
cdc Int
gen -> (Rect, SmallArray DrawOp) -> Maybe (Rect, SmallArray DrawOp)
forall a. a -> Maybe a
Just (CustomDrawOpCacheEntry -> Rect
cdeBounds CustomDrawOpCacheEntry
e, CustomDrawOpCacheEntry -> SmallArray DrawOp
cdeOps CustomDrawOpCacheEntry
e)
        Maybe CustomDrawOpCacheEntry
_ -> Maybe (Rect, SmallArray DrawOp)
forall a. Maybe a
Nothing
  serveOps hit rect (build cdc rect) (storeCustomDrawingOps ctx k content rect cdc gen)

-- | Settle a custom widget's ops for this frame and cache them for paint,
-- returning whether what it draws changed at an unchanged rect.
--
-- A widget that declares a content key is taken at its word, as a versioned
-- drawing is: an unchanged key with unchanged size, interaction state and
-- metrics neither rebuilds the ops nor repaints them, animating or not, so a
-- drawing that reads an animated value has to fold it into its key. One that
-- only moved keeps its ops too; paint translates them. Without a key (0) the
-- build can read anything (a sort flag, a fraction), and nothing but building
-- it shows that its output changed, so it is rebuilt and compared.
--
-- Whatever forced a rebuild, the ops it produced decide the damage, so a key
-- bumped without a visible change repaints nothing and a rebuild the key never
-- mentioned still repaints. A new, moved or resized widget reports no change:
-- rect damage covers it.
refreshCustomDrawingOps ::
  Context ->
  WidgetId ->
  Int ->
  Rect ->
  CustomDrawContext ->
  CustomDrawBuild ->
  IO Bool
refreshCustomDrawingOps :: Context
-> WidgetId
-> Int
-> Rect
-> CustomDrawContext
-> CustomDrawBuild
-> IO Bool
refreshCustomDrawingOps Context
ctx WidgetId
wid Int
content Rect
rect CustomDrawContext
cdc CustomDrawBuild
build = do
  let k :: Int
k = WidgetId -> Int
intKey WidgetId
wid
  gen <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Context -> IORef Int
ctxMetricGen Context
ctx)
  cached <- IM.lookup k . dcsCustomDrawOpCache <$> readIORef (ctxDrawingCache ctx)
  let keyed = Int
content Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
  case cached of
    -- A keyed widget that only moved keeps its ops: paint translates them, and
    -- the move is damaged by the rect delta.
    Just CustomDrawOpCacheEntry
e | Bool
keyed Bool -> Bool -> Bool
&& CustomDrawOpCacheEntry
-> Int -> Rect -> CustomDrawContext -> Int -> Bool
customEntryMatches CustomDrawOpCacheEntry
e Int
content Rect
rect CustomDrawContext
cdc Int
gen -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Maybe CustomDrawOpCacheEntry
_ -> do
      let ops :: SmallArray DrawOp
ops = CustomDrawBuild
build CustomDrawContext
cdc Rect
rect
          -- Whatever made this frame rebuild - the key, the interaction state,
          -- a theme or font change - the ops are built now, so ask them
          -- directly rather than trusting the key for damage as well.
          changed :: Bool
changed = case Maybe CustomDrawOpCacheEntry
cached of
            Just CustomDrawOpCacheEntry
e | CustomDrawOpCacheEntry -> Rect
cdeBounds CustomDrawOpCacheEntry
e Rect -> Rect -> Bool
forall a. Eq a => a -> a -> Bool
== Rect
rect -> CustomDrawOpCacheEntry -> SmallArray DrawOp
cdeOps CustomDrawOpCacheEntry
e SmallArray DrawOp -> SmallArray DrawOp -> Bool
forall a. Eq a => a -> a -> Bool
/= SmallArray DrawOp
ops
            Maybe CustomDrawOpCacheEntry
_ -> Bool
False
      Context
-> Int
-> Int
-> Rect
-> CustomDrawContext
-> Int
-> SmallArray DrawOp
-> IO ()
storeCustomDrawingOps Context
ctx Int
k Int
content Rect
rect CustomDrawContext
cdc Int
gen SmallArray DrawOp
ops
      Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
changed

storeCustomDrawingOps :: Context -> Int -> Int -> Rect -> CustomDrawContext -> Int -> SmallArray DrawOp -> IO ()
storeCustomDrawingOps :: Context
-> Int
-> Int
-> Rect
-> CustomDrawContext
-> Int
-> SmallArray DrawOp
-> IO ()
storeCustomDrawingOps Context
ctx Int
k Int
content Rect
rect CustomDrawContext
cdc Int
gen SmallArray DrawOp
ops =
  IORef DrawingCacheState
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx) ((DrawingCacheState -> DrawingCacheState) -> IO ())
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DrawingCacheState
s ->
    let entry :: CustomDrawOpCacheEntry
entry =
          Int
-> Rect
-> Bool
-> Bool
-> Bool
-> Bool
-> Int
-> SmallArray DrawOp
-> CustomDrawOpCacheEntry
CustomDrawOpCacheEntry
            Int
content
            Rect
rect
            (CustomDrawContext -> Bool
cdcHovered CustomDrawContext
cdc)
            (CustomDrawContext -> Bool
cdcPressed CustomDrawContext
cdc)
            (CustomDrawContext -> Bool
cdcFocused CustomDrawContext
cdc)
            (CustomDrawContext -> Bool
cdcDisabled CustomDrawContext
cdc)
            Int
gen
            SmallArray DrawOp
ops
     in DrawingCacheState
s {dcsCustomDrawOpCache = IM.insert k entry (dcsCustomDrawOpCache s)}

-- | Whether a versioned drawing's cached ops are for another version at the
-- same rect. Paint rebuilds them; the pixels they covered must repaint too,
-- and checking the version costs nothing next to building the ops here.
drawingOpsStale :: Context -> WidgetId -> Int -> Rect -> IO Bool
drawingOpsStale :: Context -> WidgetId -> Int -> Rect -> IO Bool
drawingOpsStale Context
ctx WidgetId
wid Int
content Rect
rect = do
  cached <- Int -> IntMap DrawOpCacheEntry -> Maybe DrawOpCacheEntry
forall a. Int -> IntMap a -> Maybe a
IM.lookup (WidgetId -> Int
intKey WidgetId
wid) (IntMap DrawOpCacheEntry -> Maybe DrawOpCacheEntry)
-> (DrawingCacheState -> IntMap DrawOpCacheEntry)
-> DrawingCacheState
-> Maybe DrawOpCacheEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawingCacheState -> IntMap DrawOpCacheEntry
dcsDrawOpCache (DrawingCacheState -> Maybe DrawOpCacheEntry)
-> IO DrawingCacheState -> IO (Maybe DrawOpCacheEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef DrawingCacheState -> IO DrawingCacheState
forall a. IORef a -> IO a
readIORef (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx)
  pure $ case cached of
    Just DrawOpCacheEntry {doeContent :: DrawOpCacheEntry -> Int
doeContent = Int
c, doeBounds :: DrawOpCacheEntry -> Rect
doeBounds = Rect
r} -> Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
content Bool -> Bool -> Bool
&& Rect
r Rect -> Rect -> Bool
forall a. Eq a => a -> a -> Bool
== Rect
rect
    Maybe DrawOpCacheEntry
Nothing -> Bool
False

{-# INLINE registerCustomMeasure #-}
registerCustomMeasure :: Context -> WidgetId -> CustomMeasureFn -> IO ()
registerCustomMeasure :: Context -> WidgetId -> CustomMeasureFn -> IO ()
registerCustomMeasure = (DrawingCacheState -> IntMap CustomMeasureFn)
-> (IntMap CustomMeasureFn
    -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> CustomMeasureFn
-> IO ()
forall a.
(DrawingCacheState -> IntMap a)
-> (IntMap a -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> a
-> IO ()
registerIn DrawingCacheState -> IntMap CustomMeasureFn
dcsCustomMeasures (\IntMap CustomMeasureFn
m DrawingCacheState
dc -> DrawingCacheState
dc {dcsCustomMeasures = m})

{-# INLINE lookupCustomMeasure #-}
lookupCustomMeasure :: Context -> WidgetId -> IO (Maybe CustomMeasureFn)
lookupCustomMeasure :: Context -> WidgetId -> IO (Maybe CustomMeasureFn)
lookupCustomMeasure = (DrawingCacheState -> IntMap CustomMeasureFn)
-> Context -> WidgetId -> IO (Maybe CustomMeasureFn)
forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap CustomMeasureFn
dcsCustomMeasures

{-# INLINE registerCustomCursor #-}
registerCustomCursor :: Context -> WidgetId -> (CustomDrawContext -> UiCursorKind) -> IO ()
registerCustomCursor :: Context -> WidgetId -> (CustomDrawContext -> UiCursorKind) -> IO ()
registerCustomCursor = (DrawingCacheState -> IntMap (CustomDrawContext -> UiCursorKind))
-> (IntMap (CustomDrawContext -> UiCursorKind)
    -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> (CustomDrawContext -> UiCursorKind)
-> IO ()
forall a.
(DrawingCacheState -> IntMap a)
-> (IntMap a -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> a
-> IO ()
registerIn DrawingCacheState -> IntMap (CustomDrawContext -> UiCursorKind)
dcsCustomCursors (\IntMap (CustomDrawContext -> UiCursorKind)
m DrawingCacheState
dc -> DrawingCacheState
dc {dcsCustomCursors = m})

{-# INLINE lookupCustomCursor #-}
lookupCustomCursor :: Context -> WidgetId -> IO (Maybe (CustomDrawContext -> UiCursorKind))
lookupCustomCursor :: Context
-> WidgetId -> IO (Maybe (CustomDrawContext -> UiCursorKind))
lookupCustomCursor = (DrawingCacheState -> IntMap (CustomDrawContext -> UiCursorKind))
-> Context
-> WidgetId
-> IO (Maybe (CustomDrawContext -> UiCursorKind))
forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap (CustomDrawContext -> UiCursorKind)
dcsCustomCursors

{-# INLINE registerCustomDamageSlop #-}
registerCustomDamageSlop :: Context -> WidgetId -> Float -> IO ()
registerCustomDamageSlop :: Context -> WidgetId -> Float -> IO ()
registerCustomDamageSlop = (DrawingCacheState -> IntMap Float)
-> (IntMap Float -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> Float
-> IO ()
forall a.
(DrawingCacheState -> IntMap a)
-> (IntMap a -> DrawingCacheState -> DrawingCacheState)
-> Context
-> WidgetId
-> a
-> IO ()
registerIn DrawingCacheState -> IntMap Float
dcsCustomDamageSlop (\IntMap Float
m DrawingCacheState
dc -> DrawingCacheState
dc {dcsCustomDamageSlop = m})

{-# INLINE lookupCustomDamageSlop #-}
lookupCustomDamageSlop :: Context -> WidgetId -> IO (Maybe Float)
lookupCustomDamageSlop :: Context -> WidgetId -> IO (Maybe Float)
lookupCustomDamageSlop = (DrawingCacheState -> IntMap Float)
-> Context -> WidgetId -> IO (Maybe Float)
forall a.
(DrawingCacheState -> IntMap a)
-> Context -> WidgetId -> IO (Maybe a)
lookupIn DrawingCacheState -> IntMap Float
dcsCustomDamageSlop

resetDrawingScopeCache :: Context -> IO ()
resetDrawingScopeCache :: Context -> IO ()
resetDrawingScopeCache Context
ctx =
  IORef DrawingCacheState
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx) ((DrawingCacheState -> DrawingCacheState) -> IO ())
-> (DrawingCacheState -> DrawingCacheState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DrawingCacheState
dc ->
    DrawingCacheState
dc
      { dcsDrawings = IM.empty
      , dcsPopupConfigs = IM.empty
      , dcsCustomMeasures = IM.empty
      , dcsCustomCursors = IM.empty
      , dcsCustomDrawings = IM.empty
      , dcsCustomDamageSlop = IM.empty
      }

-- | True when any node has a custom measure function, whose output is not
-- captured by the arena descriptor comparison, so whole-layout reuse must be
-- disabled for the frame.
hasCustomLayoutInputs :: Context -> IO Bool
hasCustomLayoutInputs :: Context -> IO Bool
hasCustomLayoutInputs Context
ctx =
  Bool -> Bool
not (Bool -> Bool)
-> (DrawingCacheState -> Bool) -> DrawingCacheState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap CustomMeasureFn -> Bool
forall a. IntMap a -> Bool
IM.null (IntMap CustomMeasureFn -> Bool)
-> (DrawingCacheState -> IntMap CustomMeasureFn)
-> DrawingCacheState
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawingCacheState -> IntMap CustomMeasureFn
dcsCustomMeasures (DrawingCacheState -> Bool) -> IO DrawingCacheState -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef DrawingCacheState -> IO DrawingCacheState
forall a. IORef a -> IO a
readIORef (Context -> IORef DrawingCacheState
ctxDrawingCache Context
ctx)