-- | Accessors the other Context modules build on: interaction, overlay and
-- damage state, damage requests, the dirty flag, and widget store writes.
module NanoUI.Context.Core
  ( getsInteraction
  , modifyInteraction
  , getsOverlay
  , modifyOverlay
  , getsDamage
  , modifyDamage
  -- Interaction
  , getScrollDrag
  , setTextInputDrag
  , getTextInputMenu
  , setTextInputMenu
  , takeTextEditLastAction
  , getMenuPointerGesture
  , setMenuPointerGesture
  , getWindowDrag
  , getWindowResize
  -- Damage
  , markDirty
  , clearDirty
  , isDirty
  , setWakeLoop
  , takeDamage
  , requestDamage
  , damageWidget
  , damageKey
  , damageRect
  , damagePeers
  , damageFull
  , getPrevRect
  , getPrevClipRect
  -- Store
  , getStore
  , setStore
  , modifyStore
  , getStoreBool
  , writeStoreInt
  , writeStoreFloat
  , writeStoreBool
  , adoptStoreInt
  , adoptStoreFloat
  , adoptStoreText
  , recordStoreInt
  , recordStoreFloat
  , recordStoreText
  , isDisabled
  -- Theme scopes
  , newThemeScopes
  , beginThemeScopes
  , pushThemeScope
  , themeScopesChanged
  , scopeTheme
  , scopeRawTheme
  , currentTheme
  , nodeTheme
  , widgetTheme
  ) where

import Control.Monad (forM_, when)
import Data.Bits (shiftR, (.&.))
import Data.IORef (modifyIORef', readIORef, writeIORef)
import Data.Primitive.SmallArray (copySmallMutableArray, newSmallArray, readSmallArray, getSizeofSmallMutableArray, writeSmallArray)
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IM
import Data.Text (Text)

import NanoUI.Context.Types
  ( Context (..)
  , DamageRequest (..)
  , DamageState (..)
  , InteractionState (..)
  , OverlayState
  , TextInputDrag
  , TextInputMenu
  , ThemeScopes (..)
  , WindowResizeDrag
  , intKey
  )
import NanoUI.Id (WidgetId, hashWidgetId)
import NanoUI.Layout.Arena (DirTag, NodeIdx, getArenaScope, getNodeScope, getScopeSignature, lookupNodeByWidgetId)
import NanoUI.Store
  ( WidgetStore (..)
  , boolInt
  , intBool
  , ptrEq
  , slotKey
  , Slot (..)
  )
import NanoUI.Style (Theme)
import NanoUI.Types (Damage, DamageBounds (..), Rect, defaultDamageSlop, rectH, rectW)
import NanoUI.Widgets.TextCommand (TextCommand)

-- =============================================================================
-- State records
-- =============================================================================

{-# INLINE getsInteraction #-}
getsInteraction :: Context -> (InteractionState -> a) -> IO a
getsInteraction :: forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> a
f = InteractionState -> a
f (InteractionState -> a) -> IO InteractionState -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef InteractionState -> IO InteractionState
forall a. IORef a -> IO a
readIORef (Context -> IORef InteractionState
ctxInteractionState Context
ctx)

{-# INLINE modifyInteraction #-}
modifyInteraction :: Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction :: Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx = IORef InteractionState
-> (InteractionState -> InteractionState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef InteractionState
ctxInteractionState Context
ctx)

{-# INLINE getsOverlay #-}
getsOverlay :: Context -> (OverlayState -> a) -> IO a
getsOverlay :: forall a. Context -> (OverlayState -> a) -> IO a
getsOverlay Context
ctx OverlayState -> a
f = OverlayState -> a
f (OverlayState -> a) -> IO OverlayState -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef OverlayState -> IO OverlayState
forall a. IORef a -> IO a
readIORef (Context -> IORef OverlayState
ctxOverlayState Context
ctx)

{-# INLINE modifyOverlay #-}
modifyOverlay :: Context -> (OverlayState -> OverlayState) -> IO ()
modifyOverlay :: Context -> (OverlayState -> OverlayState) -> IO ()
modifyOverlay Context
ctx = IORef OverlayState -> (OverlayState -> OverlayState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef OverlayState
ctxOverlayState Context
ctx)

{-# INLINE getsDamage #-}
getsDamage :: Context -> (DamageState -> a) -> IO a
getsDamage :: forall a. Context -> (DamageState -> a) -> IO a
getsDamage Context
ctx DamageState -> a
f = DamageState -> a
f (DamageState -> a) -> IO DamageState -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef DamageState -> IO DamageState
forall a. IORef a -> IO a
readIORef (Context -> IORef DamageState
ctxDamageState Context
ctx)

{-# INLINE modifyDamage #-}
modifyDamage :: Context -> (DamageState -> DamageState) -> IO ()
modifyDamage :: Context -> (DamageState -> DamageState) -> IO ()
modifyDamage Context
ctx = IORef DamageState -> (DamageState -> DamageState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef DamageState
ctxDamageState Context
ctx)

-- =============================================================================
-- Interaction
-- =============================================================================

{-# INLINE getScrollDrag #-}
getScrollDrag :: Context -> IO (Maybe (WidgetId, DirTag, Float))
getScrollDrag :: Context -> IO (Maybe (WidgetId, DirTag, Float))
getScrollDrag Context
ctx = Context
-> (InteractionState -> Maybe (WidgetId, DirTag, Float))
-> IO (Maybe (WidgetId, DirTag, Float))
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe (WidgetId, DirTag, Float)
isScrollDrag

{-# INLINE setTextInputDrag #-}
setTextInputDrag :: Context -> Maybe TextInputDrag -> IO ()
setTextInputDrag :: Context -> Maybe TextInputDrag -> IO ()
setTextInputDrag Context
ctx Maybe TextInputDrag
v = Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isTextInputDrag = v})

{-# INLINE getTextInputMenu #-}
getTextInputMenu :: Context -> IO (Maybe TextInputMenu)
getTextInputMenu :: Context -> IO (Maybe TextInputMenu)
getTextInputMenu Context
ctx = Context
-> (InteractionState -> Maybe TextInputMenu)
-> IO (Maybe TextInputMenu)
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe TextInputMenu
isTextInputMenu

{-# INLINE setTextInputMenu #-}
setTextInputMenu :: Context -> Maybe TextInputMenu -> IO ()
setTextInputMenu :: Context -> Maybe TextInputMenu -> IO ()
setTextInputMenu Context
ctx Maybe TextInputMenu
v = Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isTextInputMenu = v})

takeTextEditLastAction :: Context -> IO (Maybe (WidgetId, TextCommand))
takeTextEditLastAction :: Context -> IO (Maybe (WidgetId, TextCommand))
takeTextEditLastAction Context
ctx = do
  act <- Context
-> (InteractionState -> Maybe (WidgetId, TextCommand))
-> IO (Maybe (WidgetId, TextCommand))
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe (WidgetId, TextCommand)
isTextEditLastAction
  modifyInteraction ctx (\InteractionState
s -> InteractionState
s {isTextEditLastAction = Nothing})
  pure act

{-# INLINE getMenuPointerGesture #-}
getMenuPointerGesture :: Context -> IO Bool
getMenuPointerGesture :: Context -> IO Bool
getMenuPointerGesture Context
ctx = Context -> (InteractionState -> Bool) -> IO Bool
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Bool
isMenuPointerGesture

{-# INLINE setMenuPointerGesture #-}
setMenuPointerGesture :: Context -> Bool -> IO ()
setMenuPointerGesture :: Context -> Bool -> IO ()
setMenuPointerGesture Context
ctx Bool
v = Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isMenuPointerGesture = v})

{-# INLINE getWindowDrag #-}
getWindowDrag :: Context -> IO (Maybe (WidgetId, Float, Float))
getWindowDrag :: Context -> IO (Maybe (WidgetId, Float, Float))
getWindowDrag Context
ctx = Context
-> (InteractionState -> Maybe (WidgetId, Float, Float))
-> IO (Maybe (WidgetId, Float, Float))
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe (WidgetId, Float, Float)
isWindowDrag

{-# INLINE getWindowResize #-}
getWindowResize :: Context -> IO (Maybe WindowResizeDrag)
getWindowResize :: Context -> IO (Maybe WindowResizeDrag)
getWindowResize Context
ctx = Context
-> (InteractionState -> Maybe WindowResizeDrag)
-> IO (Maybe WindowResizeDrag)
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe WindowResizeDrag
isWindowResize

-- =============================================================================
-- Damage
-- =============================================================================

{-# INLINE requestDamage #-}
requestDamage :: Context -> DamageRequest -> IO ()
requestDamage :: Context -> DamageRequest -> IO ()
requestDamage Context
ctx DamageRequest
req = Context -> (DamageState -> DamageState) -> IO ()
modifyDamage Context
ctx (\DamageState
ds -> DamageState
ds {dsRequests = req : dsRequests ds})

{-# INLINE damageWidget #-}
damageWidget :: Context -> WidgetId -> DamageBounds -> IO ()
damageWidget :: Context -> WidgetId -> DamageBounds -> IO ()
damageWidget Context
ctx WidgetId
wid DamageBounds
bounds
  | WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = Context -> DamageRequest -> IO ()
requestDamage Context
ctx (WidgetId -> DamageBounds -> DamageRequest
ReqWidget WidgetId
wid DamageBounds
bounds)

{-# INLINE damageKey #-}
damageKey :: Context -> Int -> DamageBounds -> IO ()
damageKey :: Context -> Int -> DamageBounds -> IO ()
damageKey Context
ctx Int
k DamageBounds
bounds
  | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = Context -> DamageRequest -> IO ()
requestDamage Context
ctx (Int -> DamageBounds -> DamageRequest
ReqKey Int
k DamageBounds
bounds)

{-# INLINE damageRect #-}
damageRect :: Context -> Rect -> IO ()
damageRect :: Context -> Rect -> IO ()
damageRect Context
ctx Rect
r
  | Rect -> Float
rectW Rect
r Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Rect -> Float
rectH Rect
r 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 = Context -> DamageRequest -> IO ()
requestDamage Context
ctx (Rect -> DamageRequest
ReqRect Rect
r)

{-# INLINE damagePeers #-}
damagePeers :: Context -> [WidgetId] -> DamageBounds -> IO ()
damagePeers :: Context -> [WidgetId] -> DamageBounds -> IO ()
damagePeers Context
ctx [WidgetId]
wids DamageBounds
bounds =
  case (WidgetId -> Bool) -> [WidgetId] -> [WidgetId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\WidgetId
w -> WidgetId -> Word64
hashWidgetId WidgetId
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0) [WidgetId]
wids of
    [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [WidgetId]
valid -> Context -> DamageRequest -> IO ()
requestDamage Context
ctx ([WidgetId] -> DamageBounds -> DamageRequest
ReqPeers [WidgetId]
valid DamageBounds
bounds)

{-# INLINE damageFull #-}
damageFull :: Context -> IO ()
damageFull :: Context -> IO ()
damageFull Context
ctx = Context -> DamageRequest -> IO ()
requestDamage Context
ctx DamageRequest
ReqFull

{-# INLINE markDirty #-}
markDirty :: Context -> IO ()
markDirty :: Context -> IO ()
markDirty Context
ctx = do
  Context -> (DamageState -> DamageState) -> IO ()
modifyDamage Context
ctx (\DamageState
ds -> DamageState
ds {dsDirty = True})
  IORef (Maybe (IO ())) -> IO (Maybe (IO ()))
forall a. IORef a -> IO a
readIORef (Context -> IORef (Maybe (IO ()))
ctxWakeLoop Context
ctx) IO (Maybe (IO ())) -> (Maybe (IO ()) -> 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
>>= Maybe (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_

{-# INLINE clearDirty #-}
clearDirty :: Context -> IO ()
clearDirty :: Context -> IO ()
clearDirty Context
ctx = Context -> (DamageState -> DamageState) -> IO ()
modifyDamage Context
ctx (\DamageState
ds -> DamageState
ds {dsDirty = False})

{-# INLINE isDirty #-}
isDirty :: Context -> IO Bool
isDirty :: Context -> IO Bool
isDirty Context
ctx = Context -> (DamageState -> Bool) -> IO Bool
forall a. Context -> (DamageState -> a) -> IO a
getsDamage Context
ctx DamageState -> Bool
dsDirty

{-# INLINE setWakeLoop #-}
setWakeLoop :: Context -> IO () -> IO ()
setWakeLoop :: Context -> IO () -> IO ()
setWakeLoop Context
ctx IO ()
wake = IORef (Maybe (IO ())) -> Maybe (IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe (IO ()))
ctxWakeLoop Context
ctx) (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
wake)

{-# INLINE takeDamage #-}
takeDamage :: Context -> IO Damage
takeDamage :: Context -> IO Damage
takeDamage Context
ctx = Context -> (DamageState -> Damage) -> IO Damage
forall a. Context -> (DamageState -> a) -> IO a
getsDamage Context
ctx DamageState -> Damage
dsDamage

{-# INLINE getPrevRect #-}
getPrevRect :: Context -> WidgetId -> IO (Maybe Rect)
getPrevRect :: Context -> WidgetId -> IO (Maybe Rect)
getPrevRect Context
ctx WidgetId
wid = Context -> (DamageState -> Maybe Rect) -> IO (Maybe Rect)
forall a. Context -> (DamageState -> a) -> IO a
getsDamage Context
ctx (Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup (WidgetId -> Int
intKey WidgetId
wid) (IntMap Rect -> Maybe Rect)
-> (DamageState -> IntMap Rect) -> DamageState -> Maybe Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DamageState -> IntMap Rect
dsPrevRects)

{-# INLINE getPrevClipRect #-}
getPrevClipRect :: Context -> WidgetId -> IO (Maybe Rect)
getPrevClipRect :: Context -> WidgetId -> IO (Maybe Rect)
getPrevClipRect Context
ctx WidgetId
wid = Context -> (DamageState -> Maybe Rect) -> IO (Maybe Rect)
forall a. Context -> (DamageState -> a) -> IO a
getsDamage Context
ctx (Int -> IntMap Rect -> Maybe Rect
forall a. Int -> IntMap a -> Maybe a
IM.lookup (WidgetId -> Int
intKey WidgetId
wid) (IntMap Rect -> Maybe Rect)
-> (DamageState -> IntMap Rect) -> DamageState -> Maybe Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DamageState -> IntMap Rect
dsPrevClips)

-- =============================================================================
-- Store
-- =============================================================================

{-# INLINE getStore #-}
getStore :: Context -> IO WidgetStore
getStore :: Context -> IO WidgetStore
getStore Context
ctx = IORef WidgetStore -> IO WidgetStore
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetStore
ctxStore Context
ctx)

setStore :: Context -> WidgetStore -> IO ()
setStore :: Context -> WidgetStore -> IO ()
setStore Context
ctx WidgetStore
store = Context -> (WidgetStore -> WidgetStore) -> IO ()
modifyStore Context
ctx (WidgetStore -> WidgetStore -> WidgetStore
forall a b. a -> b -> a
const WidgetStore
store)

-- | Replace the store with @f@ of it, damaging the keys whose values changed
-- and waking the loop when anything did.
modifyStore :: Context -> (WidgetStore -> WidgetStore) -> IO ()
modifyStore :: Context -> (WidgetStore -> WidgetStore) -> IO ()
modifyStore Context
ctx WidgetStore -> WidgetStore
f = do
  prev <- IORef WidgetStore -> IO WidgetStore
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetStore
ctxStore Context
ctx)
  -- WHNF-force the new record: record-update arguments are unevaluated
  -- thunks, and writeIORef would otherwise park one in the long-lived store
  -- every frame.
  let !store = WidgetStore -> WidgetStore
f WidgetStore
prev
  writeIORef (ctxStore ctx) store
  let changedKeys =
        IntMap Int -> IntMap Int -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap Int
storeInt WidgetStore
prev) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ IntMap Float -> IntMap Float -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap Float
storeFloat WidgetStore
prev) (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ IntMap Double -> IntMap Double -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap Double
storeDouble WidgetStore
prev) (WidgetStore -> IntMap Double
storeDouble WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ IntMap (Float, Float) -> IntMap (Float, Float) -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
prev) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ IntMap Text -> IntMap Text -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap Text
storeText WidgetStore
prev) (WidgetStore -> IntMap Text
storeText WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ IntMap [Float] -> IntMap [Float] -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap [Float]
storeFloatList WidgetStore
prev) (WidgetStore -> IntMap [Float]
storeFloatList WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ IntMap [Int] -> IntMap [Int] -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap [Int]
storeIntList WidgetStore
prev) (WidgetStore -> IntMap [Int]
storeIntList WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ IntMap IntSet -> IntMap IntSet -> [Int]
forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys (WidgetStore -> IntMap IntSet
storeIntSet WidgetStore
prev) (WidgetStore -> IntMap IntSet
storeIntSet WidgetStore
store)
          [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (Dynamic -> Dynamic -> Bool)
-> IntMap Dynamic -> IntMap Dynamic -> [Int]
forall a. (a -> a -> Bool) -> IntMap a -> IntMap a -> [Int]
diffKeysBy Dynamic -> Dynamic -> Bool
forall a. a -> a -> Bool
ptrEq (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
prev) (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
store)
  -- The key diff doubles as the store comparison: checking 'prev /= store'
  -- first would walk every changed map twice. Its lazy concatenation stops at
  -- the first changed key and allocates less than a list per map.
  when
    ( storeMirrorGen prev /= storeMirrorGen store
        || storeOpenSelect prev /= storeOpenSelect store
        || not (null changedKeys)
    )
    $ do
      forM_ changedKeys $ \Int
k -> Context -> Int -> DamageBounds -> IO ()
damageKey Context
ctx Int
k (Float -> DamageBounds
DamageInflated Float
defaultDamageSlop)
      markDirty ctx

diffKeysBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> [Int]
diffKeysBy :: forall a. (a -> a -> Bool) -> IntMap a -> IntMap a -> [Int]
diffKeysBy a -> a -> Bool
eq IntMap a
old IntMap a
new
  -- Unchanged maps keep their identity through a record update; skip the
  -- whole merge when the caller only rebuilt a different field.
  | IntMap a -> IntMap a -> Bool
forall a. a -> a -> Bool
ptrEq IntMap a
old IntMap a
new = []
  | Bool
otherwise =
      IntMap () -> [Int]
forall a. IntMap a -> [Int]
IM.keys
        ( (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 -> Bool
eq a
a a
b then Maybe ()
forall a. Maybe a
Nothing else () -> Maybe ()
forall a. a -> Maybe a
Just ())
            ((a -> ()) -> IntMap a -> IntMap ()
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map (() -> a -> ()
forall a b. a -> b -> a
const ()))
            ((a -> ()) -> IntMap a -> IntMap ()
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map (() -> a -> ()
forall a b. a -> b -> a
const ()))
            IntMap a
old
            IntMap a
new
        )

diffKeys :: Eq a => IntMap a -> IntMap a -> [Int]
diffKeys :: forall a. Eq a => IntMap a -> IntMap a -> [Int]
diffKeys = (a -> a -> Bool) -> IntMap a -> IntMap a -> [Int]
forall a. (a -> a -> Bool) -> IntMap a -> IntMap a -> [Int]
diffKeysBy a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | Targeted single-slot write: compares only the target slot, updates one map
-- field, damages the owning widget and wakes the loop. Unlike 'setStore' it
-- never diffs the whole store, and an equal write is a no-op.
{-# INLINE writeSlot #-}
writeSlot ::
  Eq a =>
  (WidgetStore -> IntMap a) ->
  (IntMap a -> WidgetStore -> WidgetStore) ->
  Context ->
  WidgetId ->
  Int ->
  a ->
  IO ()
writeSlot :: forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> a
-> IO ()
writeSlot WidgetStore -> IntMap a
field IntMap a -> WidgetStore -> WidgetStore
setField Context
ctx WidgetId
owner Int
k a
v = do
  st <- IORef WidgetStore -> IO WidgetStore
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetStore
ctxStore Context
ctx)
  case IM.lookup k (field st) of
    Just a
old | a
old a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe a
_ -> do
      IORef WidgetStore -> WidgetStore -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetStore
ctxStore Context
ctx) (WidgetStore -> IO ()) -> WidgetStore -> IO ()
forall a b. (a -> b) -> a -> b
$! IntMap a -> WidgetStore -> WidgetStore
setField (Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k a
v (WidgetStore -> IntMap a
field WidgetStore
st)) WidgetStore
st
      Context -> WidgetId -> DamageBounds -> IO ()
damageWidget Context
ctx WidgetId
owner DamageBounds
DamageSelf
      Context -> IO ()
markDirty Context
ctx

writeStoreInt :: Context -> WidgetId -> Int -> Int -> IO ()
writeStoreInt :: Context -> WidgetId -> Int -> Int -> IO ()
writeStoreInt = (WidgetStore -> IntMap Int)
-> (IntMap Int -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> Int
-> IO ()
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> a
-> IO ()
writeSlot WidgetStore -> IntMap Int
storeInt (\IntMap Int
m WidgetStore
st -> WidgetStore
st {storeInt = m})

writeStoreFloat :: Context -> WidgetId -> Int -> Float -> IO ()
writeStoreFloat :: Context -> WidgetId -> Int -> Float -> IO ()
writeStoreFloat = (WidgetStore -> IntMap Float)
-> (IntMap Float -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> Float
-> IO ()
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> a
-> IO ()
writeSlot WidgetStore -> IntMap Float
storeFloat (\IntMap Float
m WidgetStore
st -> WidgetStore
st {storeFloat = m})

{-# INLINE writeStoreBool #-}
writeStoreBool :: Context -> WidgetId -> Bool -> IO ()
writeStoreBool :: Context -> WidgetId -> Bool -> IO ()
writeStoreBool Context
ctx WidgetId
owner Bool
v = Context -> WidgetId -> Int -> Int -> IO ()
writeStoreInt Context
ctx WidgetId
owner (WidgetId -> Int
intKey WidgetId
owner) (Bool -> Int
boolInt Bool
v)

-- | Controlled widgets take their value from the caller every frame. The
-- caller's value replaces the stored one only when it differs from the value
-- the widget last returned ('recordSlot'). An edit applied between frames,
-- such as a menu cut, then survives a caller that passes the previous result
-- back, while a value changed by the application still wins. Returns the
-- slot's value after adopting.
{-# INLINE adoptSlot #-}
adoptSlot ::
  Eq a =>
  (WidgetStore -> IntMap a) ->
  (IntMap a -> WidgetStore -> WidgetStore) ->
  Context ->
  WidgetId ->
  Int ->
  a ->
  IO a
adoptSlot :: forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> a
-> IO a
adoptSlot WidgetStore -> IntMap a
field IntMap a -> WidgetStore -> WidgetStore
setField Context
ctx WidgetId
owner Int
k a
v = do
  st <- IORef WidgetStore -> IO WidgetStore
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetStore
ctxStore Context
ctx)
  let
    m = WidgetStore -> IntMap a
field WidgetStore
st
    seenK = Slot -> Int -> Int
slotKey Slot
SlotSeen Int
k
  if IM.lookup seenK m == Just v
    then pure $! IM.findWithDefault v k m
    else do
      writeIORef (ctxStore ctx) $! setField (IM.insert seenK v (IM.insert k v m)) st
      when (IM.lookup k m /= Just v) $ do
        damageWidget ctx owner DamageSelf
        markDirty ctx
      pure v

-- | Remember the value a controlled widget returned this frame.
{-# INLINE recordSlot #-}
recordSlot ::
  Eq a =>
  (WidgetStore -> IntMap a) ->
  (IntMap a -> WidgetStore -> WidgetStore) ->
  Context ->
  Int ->
  a ->
  IO ()
recordSlot :: forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> Int
-> a
-> IO ()
recordSlot WidgetStore -> IntMap a
field IntMap a -> WidgetStore -> WidgetStore
setField Context
ctx Int
k a
v = do
  st <- IORef WidgetStore -> IO WidgetStore
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetStore
ctxStore Context
ctx)
  let seenK = Slot -> Int -> Int
slotKey Slot
SlotSeen Int
k
  when (IM.lookup seenK (field st) /= Just v) $
    writeIORef (ctxStore ctx) $! setField (IM.insert seenK v (field st)) st

adoptStoreInt :: Context -> WidgetId -> Int -> Int -> IO Int
adoptStoreInt :: Context -> WidgetId -> Int -> Int -> IO Int
adoptStoreInt = (WidgetStore -> IntMap Int)
-> (IntMap Int -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> Int
-> IO Int
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> a
-> IO a
adoptSlot WidgetStore -> IntMap Int
storeInt (\IntMap Int
m WidgetStore
st -> WidgetStore
st {storeInt = m})

adoptStoreFloat :: Context -> WidgetId -> Int -> Float -> IO Float
adoptStoreFloat :: Context -> WidgetId -> Int -> Float -> IO Float
adoptStoreFloat = (WidgetStore -> IntMap Float)
-> (IntMap Float -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> Float
-> IO Float
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> a
-> IO a
adoptSlot WidgetStore -> IntMap Float
storeFloat (\IntMap Float
m WidgetStore
st -> WidgetStore
st {storeFloat = m})

adoptStoreText :: Context -> WidgetId -> Int -> Text -> IO Text
adoptStoreText :: Context -> WidgetId -> Int -> Text -> IO Text
adoptStoreText = (WidgetStore -> IntMap Text)
-> (IntMap Text -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> Text
-> IO Text
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> WidgetId
-> Int
-> a
-> IO a
adoptSlot WidgetStore -> IntMap Text
storeText (\IntMap Text
m WidgetStore
st -> WidgetStore
st {storeText = m})

recordStoreInt :: Context -> Int -> Int -> IO ()
recordStoreInt :: Context -> Int -> Int -> IO ()
recordStoreInt = (WidgetStore -> IntMap Int)
-> (IntMap Int -> WidgetStore -> WidgetStore)
-> Context
-> Int
-> Int
-> IO ()
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> Int
-> a
-> IO ()
recordSlot WidgetStore -> IntMap Int
storeInt (\IntMap Int
m WidgetStore
st -> WidgetStore
st {storeInt = m})

recordStoreFloat :: Context -> Int -> Float -> IO ()
recordStoreFloat :: Context -> Int -> Float -> IO ()
recordStoreFloat = (WidgetStore -> IntMap Float)
-> (IntMap Float -> WidgetStore -> WidgetStore)
-> Context
-> Int
-> Float
-> IO ()
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> Int
-> a
-> IO ()
recordSlot WidgetStore -> IntMap Float
storeFloat (\IntMap Float
m WidgetStore
st -> WidgetStore
st {storeFloat = m})

recordStoreText :: Context -> Int -> Text -> IO ()
recordStoreText :: Context -> Int -> Text -> IO ()
recordStoreText = (WidgetStore -> IntMap Text)
-> (IntMap Text -> WidgetStore -> WidgetStore)
-> Context
-> Int
-> Text
-> IO ()
forall a.
Eq a =>
(WidgetStore -> IntMap a)
-> (IntMap a -> WidgetStore -> WidgetStore)
-> Context
-> Int
-> a
-> IO ()
recordSlot WidgetStore -> IntMap Text
storeText (\IntMap Text
m WidgetStore
st -> WidgetStore
st {storeText = m})

{-# INLINE getStoreBool #-}
getStoreBool :: Context -> WidgetId -> Bool -> IO Bool
getStoreBool :: Context -> WidgetId -> Bool -> IO Bool
getStoreBool Context
ctx WidgetId
wid Bool
def =
  Int -> Bool
intBool (Int -> Bool) -> (WidgetStore -> Int) -> WidgetStore -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (Bool -> Int
boolInt Bool
def) (WidgetId -> Int
intKey WidgetId
wid) (IntMap Int -> Int)
-> (WidgetStore -> IntMap Int) -> WidgetStore -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetStore -> IntMap Int
storeInt (WidgetStore -> Bool) -> IO WidgetStore -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO WidgetStore
getStore Context
ctx

-- | Whether @wid@ was declared inside a disabled scope. A widget asks before
-- its node exists, while the scope it is declared in is still the arena's.
{-# INLINE isDisabled #-}
isDisabled :: Context -> WidgetId -> IO Bool
isDisabled :: Context -> WidgetId -> IO Bool
isDisabled Context
ctx WidgetId
wid = do
  ts <- IORef ThemeScopes -> IO ThemeScopes
forall a. IORef a -> IO a
readIORef (Context -> IORef ThemeScopes
ctxThemeScopes Context
ctx)
  if tsDisabled ts then scopeDisabled ctx wid else pure False

{-# NOINLINE scopeDisabled #-}
scopeDisabled :: Context -> WidgetId -> IO Bool
scopeDisabled :: Context -> WidgetId -> IO Bool
scopeDisabled Context
ctx WidgetId
wid = do
  let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  mIdx <- NodeArena -> WidgetId -> IO (Maybe Int)
lookupNodeByWidgetId NodeArena
na WidgetId
wid
  scope <- maybe (getArenaScope na) (getNodeScope na) mIdx
  pure (scope .&. 1 /= 0)

-- =============================================================================
-- Theme scopes
-- =============================================================================

newThemeScopes :: IO ThemeScopes
newThemeScopes :: IO ThemeScopes
newThemeScopes = do
  let unset :: a
unset = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"theme scope: unset"
  cur <- Int -> Theme -> IO (SmallMutableArray (PrimState IO) Theme)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
8 Theme
forall {a}. a
unset
  raw <- newSmallArray 8 unset
  prev <- newSmallArray 8 unset
  prevRaw <- newSmallArray 8 unset
  pure
    ThemeScopes
      { tsCount = 0
      , tsThemes = cur
      , tsRaw = raw
      , tsPrevCount = 0
      , tsPrev = prev
      , tsPrevRaw = prevRaw
      , tsDisabled = False
      , tsChanged = False
      , tsPrevSig = 0
      }

-- | Start a view pass with no pushed themes. The first pass of a frame keeps
-- last frame's themes to compare against; a rebuild pass keeps comparing
-- against the same ones.
beginThemeScopes :: Context -> Bool -> IO ()
beginThemeScopes :: Context -> Bool -> IO ()
beginThemeScopes Context
ctx Bool
newFrame = do
  ts <- IORef ThemeScopes -> IO ThemeScopes
forall a. IORef a -> IO a
readIORef (Context -> IORef ThemeScopes
ctxThemeScopes Context
ctx)
  if newFrame
    then do
      sig <- getScopeSignature (ctxNodeArena ctx)
      writeIORef (ctxThemeScopes ctx) $!
        ts
          { tsCount = 0
          , tsThemes = tsPrev ts
          , tsRaw = tsPrevRaw ts
          , tsPrevCount = tsCount ts
          , tsPrev = tsThemes ts
          , tsPrevRaw = tsRaw ts
          , tsDisabled = False
          , tsChanged = False
          , tsPrevSig = sig
          }
    else writeIORef (ctxThemeScopes ctx) $! ts {tsCount = 0, tsDisabled = False, tsChanged = False}

-- | Add a scope drawn with @theme@, whose nested scopes modify @raw@ and which
-- is disabled or not, and
-- return its theme index. A theme equal to last frame's at the same index
-- keeps last frame's value.
pushThemeScope :: Context -> Bool -> Theme -> Theme -> IO Int
pushThemeScope :: Context -> Bool -> Theme -> Theme -> IO Int
pushThemeScope Context
ctx Bool
disabled Theme
raw Theme
theme = do
  ts <- IORef ThemeScopes -> IO ThemeScopes
forall a. IORef a -> IO a
readIORef (Context -> IORef ThemeScopes
ctxThemeScopes Context
ctx)
  let !i = ThemeScopes -> Int
tsCount ThemeScopes
ts
  cap <- getSizeofSmallMutableArray (tsThemes ts)
  (themes, raws) <-
    if i < cap
      then pure (tsThemes ts, tsRaw ts)
      else do
        grown <- newSmallArray (cap * 2) theme
        copySmallMutableArray grown 0 (tsThemes ts) 0 i
        grownRaw <- newSmallArray (cap * 2) raw
        copySmallMutableArray grownRaw 0 (tsRaw ts) 0 i
        pure (grown, grownRaw)
  same <-
    if i < tsPrevCount ts
      then (== theme) <$> readSmallArray (tsPrev ts) i
      else pure False
  writeSmallArray themes i theme
  writeSmallArray raws i raw
  writeIORef (ctxThemeScopes ctx) $!
    ts {tsCount = i + 1, tsThemes = themes, tsRaw = raws, tsDisabled = tsDisabled ts || disabled, tsChanged = tsChanged ts || not same}
  pure (i + 1)

-- | Whether this frame's scopes look different from last frame's: a theme
-- changed, scopes were added or dropped, or nodes moved between scopes.
themeScopesChanged :: Context -> IO Bool
themeScopesChanged :: Context -> IO Bool
themeScopesChanged Context
ctx = do
  ts <- IORef ThemeScopes -> IO ThemeScopes
forall a. IORef a -> IO a
readIORef (Context -> IORef ThemeScopes
ctxThemeScopes Context
ctx)
  sig <- getScopeSignature (ctxNodeArena ctx)
  pure (tsChanged ts || tsCount ts /= tsPrevCount ts || sig /= tsPrevSig ts)

{-# INLINE scopeTheme #-}
scopeTheme :: Context -> Int -> IO Theme
scopeTheme :: Context -> Int -> IO Theme
scopeTheme Context
ctx Int
scope
  | Int
ti Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = IORef Theme -> IO Theme
forall a. IORef a -> IO a
readIORef (Context -> IORef Theme
ctxTheme Context
ctx)
  | Bool
otherwise = do
      ts <- IORef ThemeScopes -> IO ThemeScopes
forall a. IORef a -> IO a
readIORef (Context -> IORef ThemeScopes
ctxThemeScopes Context
ctx)
      readSmallArray (tsThemes ts) (ti - 1)
  where
    !ti :: Int
ti = Int
scope Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1

-- | A scope's theme before any disabled scope faded it.
scopeRawTheme :: Context -> Int -> IO Theme
scopeRawTheme :: Context -> Int -> IO Theme
scopeRawTheme Context
ctx Int
scope
  | Int
ti Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = IORef Theme -> IO Theme
forall a. IORef a -> IO a
readIORef (Context -> IORef Theme
ctxTheme Context
ctx)
  | Bool
otherwise = do
      ts <- IORef ThemeScopes -> IO ThemeScopes
forall a. IORef a -> IO a
readIORef (Context -> IORef ThemeScopes
ctxThemeScopes Context
ctx)
      readSmallArray (tsRaw ts) (ti - 1)
  where
    !ti :: Int
ti = Int
scope Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1

-- | The theme of the scope the view is declaring in.
{-# INLINE currentTheme #-}
currentTheme :: Context -> IO Theme
currentTheme :: Context -> IO Theme
currentTheme Context
ctx = NodeArena -> IO Int
getArenaScope (Context -> NodeArena
ctxNodeArena Context
ctx) IO Int -> (Int -> IO Theme) -> IO Theme
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> Int -> IO Theme
scopeTheme Context
ctx

{-# INLINE nodeTheme #-}
nodeTheme :: Context -> NodeIdx -> IO Theme
nodeTheme :: Context -> Int -> IO Theme
nodeTheme Context
ctx Int
idx = NodeArena -> Int -> IO Int
getNodeScope (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx IO Int -> (Int -> IO Theme) -> IO Theme
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> Int -> IO Theme
scopeTheme Context
ctx

-- | The theme of @wid@'s node, or of the current scope before it has one.
widgetTheme :: Context -> WidgetId -> IO Theme
widgetTheme :: Context -> WidgetId -> IO Theme
widgetTheme Context
ctx WidgetId
wid = do
  ts <- IORef ThemeScopes -> IO ThemeScopes
forall a. IORef a -> IO a
readIORef (Context -> IORef ThemeScopes
ctxThemeScopes Context
ctx)
  if tsCount ts == 0
    then readIORef (ctxTheme ctx)
    else lookupNodeByWidgetId (ctxNodeArena ctx) wid >>= maybe (currentTheme ctx) (nodeTheme ctx)