-- | The 'Context' a view runs against, and the operations on its state:
-- focus, dirty flags and damage, the widget store, drawing and measure
-- caches, overlays, and host hooks. Backends and advanced widgets use this
-- module; views normally only need "NanoUI".
module NanoUI.Context
  ( Context (..)
  , MeasureCacheKey
  , TextInputMenu (..)
  , TextInputDrag (..)
  , TextFieldClickCell (..)
  , WindowResizeEdge (..)
  , WindowResizeDrag (..)
  , DamageState (..)
  , OverlayState (..)
  , AnimationState (..)
  , DrawingCacheState (..)
  , DrawingEntry (..)
  , DrawFitCache (..)
  , SpanCacheEntry (..)
  , WidgetTextCacheEntry (..)
  , WidgetTextPlacement (..)
  , InteractionState (..)
  , initialInteractionState
  , initialDamageState
  , initialOverlayState
  , initialAnimationState
  , initialScrollState
  , initialDrawingCacheState
  , getsInteraction
  , modifyInteraction
  , getsOverlay
  , modifyOverlay
  , getsDamage
  , modifyDamage
  , getScrollDrag
  , setTextInputDrag
  , getTextInputMenu
  , setTextInputMenu
  , takeTextEditLastAction
  , getMenuPointerGesture
  , setMenuPointerGesture
  , getWindowDrag
  , getWindowResize
  , intKey
  , markDirty
  , clearDirty
  , isDirty
  , setWakeLoop
  , takeDamage
  , DamageRequest (..)
  , requestDamage
  , damageWidget
  , damageKey
  , damageRect
  , damagePeers
  , damageFull
  , registerPopupConfig
  , lookupPopupConfig
  , registerDrawing
  , lookupDrawing
  , cachedDrawingOps
  , cachedWidgetLayout
  , lookupDrawFitEnvelope
  , pruneDrawOpCache
  , CustomMeasureFn
  , CustomDrawContext (..)
  , CustomDrawBuild
  , registerCustomDrawing
  , lookupCustomDrawing
  , cachedCustomDrawingOps
  , refreshCustomDrawingOps
  , drawingOpsStale
  , CustomDrawingEntry (..)
  , registerCustomMeasure
  , lookupCustomMeasure
  , registerCustomCursor
  , lookupCustomCursor
  , registerCustomDamageSlop
  , lookupCustomDamageSlop
  , resetDrawingScopeCache
  , getStore
  , setStore
  , modifyStore
  , getStoreBool
  , writeStoreInt
  , writeStoreFloat
  , writeStoreBool
  , adoptStoreInt
  , adoptStoreFloat
  , adoptStoreText
  , recordStoreInt
  , recordStoreFloat
  , recordStoreText
  , isDisabled
  , newThemeScopes
  , beginThemeScopes
  , pushThemeScope
  , themeScopesChanged
  , scopeTheme
  , scopeRawTheme
  , currentTheme
  , nodeTheme
  , widgetTheme
  , getScrollOffset
  , setScrollOffset
  , getScrollOffset2D
  , setScrollOffset2D
  , setScrollConfig
  , defaultScrollConfig
  , linkScrollAxes
  , ScrollTuning (..)
  , defaultScrollTuning
  , getScrollTuning
  , setScrollTuning
  , getScrollStep
  , setScrollStep
  , resolveScrollStep
  , ScrollAxes (..)
  , ScrollMetrics (..)
  , getScrollMetrics
  , cacheScrollMetrics
  , beginScrollMetrics
  , getScrollOffsetIn
  , setScrollOffsetIn
  , ScrollBehavior (..)
  , ScrollAlign (..)
  , scrollTo
  , scrollBy
  , scrollPages
  , scrollToStart
  , scrollToEnd
  , scrollIntoView
  , scrollRectIntoView
  , applyScrollTarget
  , scrollTargetOffset
  , scrollGliding
  , clampScrollOffset
  , cancelScrollGlide
  , stepScrollGlides
  , getPrevRect
  , getPrevClipRect
  , atlasTextureId
  , registerImage
  , registerImages
  , lookupImageUv
  , atlasSnapshot
  , withFontMetrics
  , withMonoFontMetrics
  , withMeasureText
  , withFontResolver
  , wrapMeasureCache
  , clearMeasureCache
  , ensureMetricCaches
  , hasCustomLayoutInputs
  , withExternalText
  , withTheme
  , setTheme
  , getTheme
  , withClipboard
  , enableMeasureCache
  , setHost
  , setDrawSnapScale
  , setDrawSquareGeometry
  , setDrawExternalText
  , askHostIO
  , pushMessage
  , drainMessages
  -- Constructors
  , newContext
  , newPixelHostContext
  -- Focus
  , getFocusId
  , getFocusVisible
  , getHotId
  , registerFocusable
  , getFocusables
  -- Modal & Overlay
  , textInputEditActive
  , modalActive
  , overlayConsumesQuit
  , markEscapeConsumed
  , pointerBlockedByModal
  , pointerBlockedByOverlay
  , armMenuPointerCapture
  , seedFloatingPanel
  , beginModal
  , endModal
  , beginFrameModal
  , modalDamageFlip
  -- Animation
  , anyAnimating
  , getLiveAnimations
  , takeAnimSettled
  , lookupAnimation
  , getAnimRectless
  , setAnimRectless
  , startAnimation
  , startAnimationEase
  , startAnimationEaseDelay
  , startSpring
  , setAnimationValue
  , tickAnimations
  , getAnimationValue
  , getAnimRest
  , pruneAnimRest
  , FrameMsg (..)
  , decodeMessages
  , reduceMessages
  , reduceUpdates
  , WidgetStore (..)
  , bumpMirror
  , slotKey
  , Slot (..)
  , boolInt
  , intBool
  , anySelectOpen
  , isSelectOpen
  , setSelectOpen
  , closeSelects
  , Ease (..)
  , Animation (..)
  , SpringParams (..)
  , presetBouncy
  , presetSmooth
  , presetStiff
  , applyEase
  , easeSameSpec
  , approxEq
  , animInProgress
  ) where

import Control.Monad (foldM, forM, when)
import Data.Bits ((.&.))
import Data.ByteString (ByteString)
import Data.Dynamic (fromDynamic, toDyn)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.IntMap.Strict qualified as IM
import Data.Map.Strict qualified as Map
import Data.Primitive.PrimArray
  ( newPrimArray
  , readPrimArray
  , writePrimArray
  , getSizeofMutablePrimArray
  , resizeMutablePrimArray
  )
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Typeable (Typeable, typeOf, typeRep)
import Data.Word (Word8)
import Foreign.ForeignPtr (ForeignPtr)

import NanoUI.Animation
  ( Animation (..)
  , Ease (..)
  , SpringParams (..)
  , animInProgress
  , applyEase
  , approxEq
  , easeSameSpec
  , presetBouncy
  , presetSmooth
  , presetStiff
  )
import NanoUI.Atlas (atlasTextureId)
import NanoUI.Atlas qualified as Atlas
import NanoUI.Context.Animation
import NanoUI.Context.Core
import NanoUI.Context.Drawing
import NanoUI.Context.Overlay
import NanoUI.Context.Scroll
import NanoUI.Context.Types
  ( AnimationState (..)
  , Context (..)
  , CustomDrawBuild
  , CustomDrawContext (..)
  , CustomDrawingEntry (..)
  , CustomMeasureFn
  , DamageRequest (..)
  , DamageState (..)
  , DrawFitCache (..)
  , DrawingCacheState (..)
  , DrawingEntry (..)
  , FrameMsg (..)
  , InteractionState (..)
  , MeasureCacheKey
  , MetricSource (..)
  , OverlayState (..)
  , SpanCacheEntry (..)
  , TextFieldClickCell (..)
  , TextInputDrag (..)
  , TextInputMenu (..)
  , WidgetTextCacheEntry (..)
  , WidgetTextPlacement (..)
  , WindowResizeDrag (..)
  , WindowResizeEdge (..)
  , decodeMessages
  , initialAnimationState
  , initialScrollState
  , initialDamageState
  , initialDrawingCacheState
  , initialInteractionState
  , initialOverlayState
  , intKey
  , reduceMessages
  , reduceUpdates
  )
import NanoUI.Draw (newDrawArena)
import NanoUI.Draw qualified as Draw
import NanoUI.Font (FontMetrics, fmLineHeight, measureTextIO, monospaceMetrics, scaleFontMetrics)
import NanoUI.Frame.SpanArena (newSpanArena)
import NanoUI.Frame.Scroll.Geometry (defaultScrollConfig)
import NanoUI.Id (WidgetId (..), initialIdContext)
import NanoUI.Layout.Arena (getArenaScope, newNodeArena)
import NanoUI.Store
  ( WidgetStore (..)
  , anySelectOpen
  , boolInt
  , bumpMirror
  , closeSelects
  , emptyWidgetStore
  , intBool
  , isSelectOpen
  , ptrEq
  , setSelectOpen
  , Slot (..)
  , slotKey
  )
import NanoUI.Style (FontStyle, FontVariant (..), FontWeight, Theme, defaultLayout, defaultTheme)
import NanoUI.Types (ImageId)

{-# INLINE registerImage #-}
registerImage :: Context -> ImageId -> Int -> Int -> ByteString -> IO Bool
registerImage :: Context -> ImageId -> Int -> Int -> ByteString -> IO Bool
registerImage Context
ctx ImageId
iid Int
w Int
h ByteString
px = do
  ok <- ImageAtlas -> ImageId -> Int -> Int -> ByteString -> IO Bool
Atlas.registerImage (Context -> ImageAtlas
ctxImageAtlas Context
ctx) ImageId
iid Int
w Int
h ByteString
px
  when ok (markDirty ctx)
  pure ok

registerImages :: Foldable f => Context -> f (ImageId, Int, Int, ByteString) -> IO Bool
registerImages :: forall (f :: * -> *).
Foldable f =>
Context -> f (ImageId, Int, Int, ByteString) -> IO Bool
registerImages Context
ctx = (Bool -> (ImageId, Int, Int, ByteString) -> IO Bool)
-> Bool -> f (ImageId, Int, Int, ByteString) -> IO Bool
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Bool -> (ImageId, Int, Int, ByteString) -> IO Bool
register Bool
True
  where
    register :: Bool -> (ImageId, Int, Int, ByteString) -> IO Bool
register Bool
ok (ImageId
iid, Int
w, Int
h, ByteString
px) = do
      result <- Context -> ImageId -> Int -> Int -> ByteString -> IO Bool
registerImage Context
ctx ImageId
iid Int
w Int
h ByteString
px
      pure (ok && result)

{-# INLINE lookupImageUv #-}
lookupImageUv :: Context -> ImageId -> IO (Maybe (Float, Float, Float, Float))
lookupImageUv :: Context -> ImageId -> IO (Maybe (Float, Float, Float, Float))
lookupImageUv Context
ctx = ImageAtlas -> ImageId -> IO (Maybe (Float, Float, Float, Float))
Atlas.lookupImageUv (Context -> ImageAtlas
ctxImageAtlas Context
ctx)

{-# INLINE atlasSnapshot #-}
atlasSnapshot :: Context -> IO (Maybe (Int, Int, ForeignPtr Word8, Int))
atlasSnapshot :: Context -> IO (Maybe (Int, Int, ForeignPtr Word8, Int))
atlasSnapshot Context
ctx = ImageAtlas -> IO (Maybe (Int, Int, ForeignPtr Word8, Int))
Atlas.atlasSnapshot (Context -> ImageAtlas
ctxImageAtlas Context
ctx)

-- | Metrics for a font variant scaled to line height @sz@, and the scale
-- factor applied (1 when @sz@ or the base line height is not positive).
{-# INLINE resolveScale #-}
resolveScale :: Context -> Float -> FontVariant -> (FontMetrics, Float)
resolveScale :: Context -> Float -> FontVariant -> (FontMetrics, Float)
resolveScale Context
ctx Float
sz FontVariant
var =
  let baseFm :: FontMetrics
baseFm = if FontVariant
var FontVariant -> FontVariant -> Bool
forall a. Eq a => a -> a -> Bool
== FontVariant
FontMono then Context -> FontMetrics
ctxMonoFontMetrics Context
ctx else Context -> FontMetrics
ctxFontMetrics Context
ctx
      scale :: Float
scale =
        if Float
sz Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& FontMetrics -> Float
fmLineHeight FontMetrics
baseFm Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0
          then Float
sz Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ FontMetrics -> Float
fmLineHeight FontMetrics
baseFm
          else Float
1.0
   in (if Float
scale Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
1.0 then Float -> FontMetrics -> FontMetrics
scaleFontMetrics Float
scale FontMetrics
baseFm else FontMetrics
baseFm, Float
scale)

defaultResolveFont :: Context -> Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool)
defaultResolveFont :: Context
-> Float
-> FontWeight
-> FontStyle
-> FontVariant
-> IO (FontMetrics, Bool)
defaultResolveFont Context
ctx Float
sz FontWeight
_w FontStyle
_st FontVariant
var = (FontMetrics, Bool) -> IO (FontMetrics, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FontMetrics, Float) -> FontMetrics
forall a b. (a, b) -> a
fst (Context -> Float -> FontVariant -> (FontMetrics, Float)
resolveScale Context
ctx Float
sz FontVariant
var), Bool
False)

defaultResolveMeasure :: Context -> Float -> FontWeight -> FontStyle -> FontVariant -> Text -> IO (Float, Float)
defaultResolveMeasure :: Context
-> Float
-> FontWeight
-> FontStyle
-> FontVariant
-> Text
-> IO (Float, Float)
defaultResolveMeasure Context
ctx Float
sz FontWeight
_w FontStyle
_st FontVariant
var Text
txt
  | FontVariant
var FontVariant -> FontVariant -> Bool
forall a. Eq a => a -> a -> Bool
== FontVariant
FontMono = FontMetrics -> Text -> IO (Float, Float)
measureTextIO FontMetrics
textFm Text
txt
  | Float
scale Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
1.0 = (\(Float
w, Float
h) -> (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale, Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale)) ((Float, Float) -> (Float, Float))
-> IO (Float, Float) -> IO (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Text -> IO (Float, Float)
ctxMeasureText Context
ctx Text
txt
  | Bool
otherwise = Context -> Text -> IO (Float, Float)
ctxMeasureText Context
ctx Text
txt
  where
    (FontMetrics
textFm, Float
scale) = Context -> Float -> FontVariant -> (FontMetrics, Float)
resolveScale Context
ctx Float
sz FontVariant
var

{-# INLINE withFontResolver #-}
withFontResolver ::
  Context ->
  (Float -> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool)) ->
  (Float -> FontWeight -> FontStyle -> FontVariant -> Text -> IO (Float, Float)) ->
  Context
withFontResolver :: Context
-> (Float
    -> FontWeight
    -> FontStyle
    -> FontVariant
    -> IO (FontMetrics, Bool))
-> (Float
    -> FontWeight
    -> FontStyle
    -> FontVariant
    -> Text
    -> IO (Float, Float))
-> Context
withFontResolver Context
ctx Float
-> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool)
rf Float
-> FontWeight
-> FontStyle
-> FontVariant
-> Text
-> IO (Float, Float)
rm = Context -> Context
trackMetricSource Context
ctx {ctxResolveFont = rf, ctxResolveMeasure = rm}

withFontMetrics :: Context -> FontMetrics -> Context
withFontMetrics :: Context -> FontMetrics -> Context
withFontMetrics Context
ctx FontMetrics
fm =
  let ctx' :: Context
ctx' =
        Context
ctx
          { ctxFontMetrics = fm
          , ctxMeasureText = measureTextIO fm
          }
   in Context -> Context
trackMetricSource Context
ctx'
        { ctxResolveFont = defaultResolveFont ctx'
        , ctxResolveMeasure = defaultResolveMeasure ctx'
        }

withMonoFontMetrics :: Context -> FontMetrics -> Context
withMonoFontMetrics :: Context -> FontMetrics -> Context
withMonoFontMetrics Context
ctx FontMetrics
mono =
  let ctx' :: Context
ctx' = Context
ctx {ctxMonoFontMetrics = mono}
   in Context -> Context
trackMetricSource Context
ctx'
        { ctxResolveFont = defaultResolveFont ctx'
        , ctxResolveMeasure = defaultResolveMeasure ctx'
        }

withMeasureText :: Context -> (Text -> IO (Float, Float)) -> Context
withMeasureText :: Context -> (Text -> IO (Float, Float)) -> Context
withMeasureText Context
ctx Text -> IO (Float, Float)
fn =
  let ctx' :: Context
ctx' = Context
ctx {ctxMeasureText = fn}
   in Context -> Context
trackMetricSource Context
ctx'
        { ctxResolveMeasure = defaultResolveMeasure ctx'
        }

-- Keep the identity boxed. No structural callback comparison or unsafe pure
-- mutation is needed, and repeated frames with the same Context do no work.
trackMetricSource :: Context -> Context
trackMetricSource :: Context -> Context
trackMetricSource Context
ctx =
  Context
ctx {ctxMetricSource = MetricSource
    (ctxFontMetrics ctx) (ctxMonoFontMetrics ctx) (ctxMeasureText ctx)
    (ctxResolveFont ctx) (ctxResolveMeasure ctx)}

-- | Called once before building a frame. Context configuration remains pure;
-- cache invalidation happens at the IO boundary, including when alternating
-- between differently configured Contexts that share their backing stores.
ensureMetricCaches :: Context -> IO ()
ensureMetricCaches :: Context -> IO ()
ensureMetricCaches Context
ctx = do
  -- Compare evaluated identities: passed unevaluated, the selector application
  -- is a fresh thunk without optimisation, so the check would miss every
  -- frame and force full damage with cleared caches.
  let !current :: MetricSource
current = Context -> MetricSource
ctxMetricSource Context
ctx
  previous <- IORef (Maybe MetricSource) -> IO (Maybe MetricSource)
forall a. IORef a -> IO a
readIORef (Context -> IORef (Maybe MetricSource)
ctxLastMetricSource Context
ctx)
  case previous of
    Just MetricSource
source | MetricSource -> MetricSource -> Bool
forall a. a -> a -> Bool
ptrEq MetricSource
source MetricSource
current -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe MetricSource
_ -> do
      Context -> IO ()
clearMeasureCache Context
ctx
      Context -> IO ()
damageFull Context
ctx
      Context -> IO ()
markDirty Context
ctx

cacheMeasureText ::
  IORef (HashMap MeasureCacheKey (Float, Float)) ->
  Float ->
  (Text -> IO (Float, Float)) ->
  Text ->
  IO (Float, Float)
cacheMeasureText :: IORef (HashMap (Text, Float) (Float, Float))
-> Float
-> (Text -> IO (Float, Float))
-> Text
-> IO (Float, Float)
cacheMeasureText IORef (HashMap (Text, Float) (Float, Float))
ref Float
scale Text -> IO (Float, Float)
base Text
txt = do
  let key :: (Text, Float)
key = (Text
txt, Float
scale)
  m <- IORef (HashMap (Text, Float) (Float, Float))
-> IO (HashMap (Text, Float) (Float, Float))
forall a. IORef a -> IO a
readIORef IORef (HashMap (Text, Float) (Float, Float))
ref
  case HashMap.lookup key m of
    Just (Float, Float)
sz -> (Float, Float) -> IO (Float, Float)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float, Float)
sz
    Maybe (Float, Float)
Nothing -> do
      sz <- Text -> IO (Float, Float)
base Text
txt
      modifyIORef' ref (HashMap.insert key sz)
      pure sz

wrapMeasureCache :: Float -> Context -> (Text -> IO (Float, Float)) -> Context
wrapMeasureCache :: Float -> Context -> (Text -> IO (Float, Float)) -> Context
wrapMeasureCache Float
scale Context
ctx Text -> IO (Float, Float)
measure =
  case Context -> Maybe (IORef (HashMap (Text, Float) (Float, Float)))
ctxMeasureCache Context
ctx of
    Maybe (IORef (HashMap (Text, Float) (Float, Float)))
Nothing -> Context -> Context
trackMetricSource Context
ctx {ctxMeasureText = measure}
    Just IORef (HashMap (Text, Float) (Float, Float))
ref -> Context -> Context
trackMetricSource Context
ctx {ctxMeasureText = cacheMeasureText ref scale measure}

-- | Drop text span, widget text and whole-layout caches and bump the metric
-- generation, for changes that alter how text lays out.
invalidateTextCaches :: Context -> IO ()
invalidateTextCaches :: Context -> IO ()
invalidateTextCaches Context
ctx = do
  IORef (IntMap SpanCacheEntry) -> IntMap SpanCacheEntry -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (IntMap SpanCacheEntry)
ctxSpanCache Context
ctx) IntMap SpanCacheEntry
forall a. IntMap a
IM.empty
  IORef (IntMap WidgetTextCacheEntry)
-> IntMap WidgetTextCacheEntry -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (IntMap WidgetTextCacheEntry)
ctxWidgetTextCache Context
ctx) IntMap WidgetTextCacheEntry
forall a. IntMap a
IM.empty
  IORef (Maybe (LayoutCache, Size, Int))
-> Maybe (LayoutCache, Size, Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe (LayoutCache, Size, Int))
ctxLayoutCache Context
ctx) Maybe (LayoutCache, Size, Int)
forall a. Maybe a
Nothing
  IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef Int
ctxMetricGen Context
ctx) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

clearMeasureCache :: Context -> IO ()
clearMeasureCache :: Context -> IO ()
clearMeasureCache Context
ctx = do
  -- Store the evaluated source so 'ensureMetricCaches' can match its identity.
  let !source :: MetricSource
source = Context -> MetricSource
ctxMetricSource Context
ctx
  IORef (Maybe MetricSource) -> Maybe MetricSource -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe MetricSource)
ctxLastMetricSource Context
ctx) (MetricSource -> Maybe MetricSource
forall a. a -> Maybe a
Just MetricSource
source)
  Context -> IO ()
invalidateTextCaches Context
ctx
  case Context -> Maybe (IORef (HashMap (Text, Float) (Float, Float)))
ctxMeasureCache Context
ctx of
    Just IORef (HashMap (Text, Float) (Float, Float))
ref -> IORef (HashMap (Text, Float) (Float, Float))
-> HashMap (Text, Float) (Float, Float) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (HashMap (Text, Float) (Float, Float))
ref HashMap (Text, Float) (Float, Float)
forall k v. HashMap k v
HashMap.empty
    Maybe (IORef (HashMap (Text, Float) (Float, Float)))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

withExternalText :: Context -> Bool -> Context
withExternalText :: Context -> Bool -> Context
withExternalText Context
ctx Bool
ext = Context
ctx {ctxExternalText = ext}

-- | Configure a context's theme. Goes through 'setTheme' so a theme swapped
-- between frames invalidates the caches keyed on it, drawing-op caches
-- included, instead of leaving widgets painting the previous theme.
withTheme :: Context -> Theme -> IO Context
withTheme :: Context -> Theme -> IO Context
withTheme Context
ctx Theme
theme = do
  Context -> Theme -> IO ()
setTheme Context
ctx Theme
theme
  Context -> IO Context
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context
ctx

setTheme :: Context -> Theme -> IO ()
setTheme :: Context -> Theme -> IO ()
setTheme Context
ctx Theme
th = do
  cur <- IORef Theme -> IO Theme
forall a. IORef a -> IO a
readIORef (Context -> IORef Theme
ctxTheme Context
ctx)
  when (cur /= th) $ do
    writeIORef (ctxTheme ctx) th
    invalidateTextCaches ctx
    damageFull ctx
    markDirty ctx

getTheme :: Context -> IO Theme
getTheme :: Context -> IO Theme
getTheme Context
ctx = IORef Theme -> IO Theme
forall a. IORef a -> IO a
readIORef (Context -> IORef Theme
ctxTheme Context
ctx)

withClipboard :: Context -> IO (Maybe Text) -> (Text -> IO Bool) -> Context
withClipboard :: Context -> IO (Maybe Text) -> (Text -> IO Bool) -> Context
withClipboard Context
ctx IO (Maybe Text)
getter Text -> IO Bool
setter = Context
ctx {ctxClipboardGet = getter, ctxClipboardSet = setter}

enableMeasureCache :: Context -> IO Context
enableMeasureCache :: Context -> IO Context
enableMeasureCache Context
ctx =
  case Context -> Maybe (IORef (HashMap (Text, Float) (Float, Float)))
ctxMeasureCache Context
ctx of
    Just IORef (HashMap (Text, Float) (Float, Float))
_ -> Context -> IO Context
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context
ctx
    Maybe (IORef (HashMap (Text, Float) (Float, Float)))
Nothing -> do
      ref <- HashMap (Text, Float) (Float, Float)
-> IO (IORef (HashMap (Text, Float) (Float, Float)))
forall a. a -> IO (IORef a)
newIORef HashMap (Text, Float) (Float, Float)
forall k v. HashMap k v
HashMap.empty
      pure ctx {ctxMeasureCache = Just ref, ctxMeasureText = cacheMeasureText ref 0 (ctxMeasureText ctx)}

{-# INLINE setHost #-}
setHost :: forall a. (Typeable a) => Context -> a -> IO ()
setHost :: forall a. Typeable a => Context -> a -> IO ()
setHost Context
ctx a
val = do
  m <- IORef (Map TypeRep Dynamic) -> IO (Map TypeRep Dynamic)
forall a. IORef a -> IO a
readIORef (Context -> IORef (Map TypeRep Dynamic)
ctxHost Context
ctx)
  let k = a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
val
  writeIORef (ctxHost ctx) (Map.insert k (toDyn val) m)

-- | Set the device pixel scale used to snap geometry origins/endpoints to
-- whole pixels. The SDL backend calls this when the window pixel density is synced.
{-# INLINE setDrawSnapScale #-}
setDrawSnapScale :: Context -> Float -> IO ()
setDrawSnapScale :: Context -> Float -> IO ()
setDrawSnapScale Context
ctx Float
s = DrawArena -> Float -> IO ()
Draw.setDrawSnapScale (Context -> DrawArena
ctxDrawArena Context
ctx) Float
s

-- | Emit rounded shapes and AA strokes as flat, axis-aligned fills. Software
-- framebuffer hosts enable this so every primitive is a solid quad.
{-# INLINE setDrawSquareGeometry #-}
setDrawSquareGeometry :: Context -> Bool -> IO ()
setDrawSquareGeometry :: Context -> Bool -> IO ()
setDrawSquareGeometry Context
ctx = DrawArena -> Bool -> IO ()
Draw.setDrawSquareGeometry (Context -> DrawArena
ctxDrawArena Context
ctx)

-- | Skip text quads in the draw buffer. Hosts that rasterize text from the
-- collected text spans enable this.
{-# INLINE setDrawExternalText #-}
setDrawExternalText :: Context -> Bool -> IO ()
setDrawExternalText :: Context -> Bool -> IO ()
setDrawExternalText Context
ctx = DrawArena -> Bool -> IO ()
Draw.setDrawExternalText (Context -> DrawArena
ctxDrawArena Context
ctx)

{-# INLINE askHostIO #-}
askHostIO :: forall a. (Typeable a) => Context -> IO (Maybe a)
askHostIO :: forall a. Typeable a => Context -> IO (Maybe a)
askHostIO Context
ctx = do
  m <- IORef (Map TypeRep Dynamic) -> IO (Map TypeRep Dynamic)
forall a. IORef a -> IO a
readIORef (Context -> IORef (Map TypeRep Dynamic)
ctxHost Context
ctx)
  let k = Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
  pure (Map.lookup k m >>= fromDynamic)

{-# INLINE pushMessage #-}
pushMessage :: Context -> FrameMsg -> IO ()
pushMessage :: Context -> FrameMsg -> IO ()
pushMessage Context
ctx FrameMsg
msg = IORef [FrameMsg] -> ([FrameMsg] -> [FrameMsg]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef [FrameMsg]
ctxMessages Context
ctx) (FrameMsg
msg FrameMsg -> [FrameMsg] -> [FrameMsg]
forall a. a -> [a] -> [a]
:)

{-# INLINE drainMessages #-}
drainMessages :: Context -> IO [FrameMsg]
drainMessages :: Context -> IO [FrameMsg]
drainMessages Context
ctx = do
  msgs <- IORef [FrameMsg] -> IO [FrameMsg]
forall a. IORef a -> IO a
readIORef (Context -> IORef [FrameMsg]
ctxMessages Context
ctx)
  writeIORef (ctxMessages ctx) []
  pure (reverse msgs)

-- =============================================================================
-- Constructors
-- =============================================================================

newContext :: IO Context
newContext :: IO Context
newContext = do
  nodeArena <- IO NodeArena
newNodeArena
  drawArena <- newDrawArena
  ctxHotId <- newIORef (WidgetId 0)
  ctxLastHotId <- newIORef (WidgetId 0)
  ctxActiveId <- newIORef (WidgetId 0)
  ctxClickedId <- newIORef (WidgetId 0)
  ctxReleaseClickedId <- newIORef (WidgetId 0)
  ctxPressPos <- newIORef Nothing
  ctxRightPressPos <- newIORef Nothing
  ctxFocusId <- newIORef (WidgetId 0)
  ctxFocusVisible <- newIORef False
  ctxStore <- newIORef emptyWidgetStore
  ctxDamageState <- newIORef initialDamageState
  ctxOverlayState <- newIORef initialOverlayState
  ctxAnimationState <- newIORef initialAnimationState
  ctxScrollState <- newIORef initialScrollState
  ctxDrawingCache <- newIORef initialDrawingCacheState
  ctxIdContext <- newIORef initialIdContext
  ctxContainerStack <- newIORef []
  ctxMessages <- newIORef []
  let initCap = Int
64
  ctxFocusables <- newIORef =<< newPrimArray initCap
  ctxFocusablesCount <- newIORef 0
  ctxSpanBase <- newSpanArena 64
  ctxSpanOverlay <- newSpanArena 64
  ctxInteractionState <- newIORef initialInteractionState
  ctxImageAtlas <- Atlas.newImageAtlas
  ctxWakeLoop <- newIORef Nothing
  ctxHost <- newIORef Map.empty
  ctxDefaultLayout <- newIORef defaultLayout
  ctxTheme <- newIORef defaultTheme
  ctxThemeScopes <- newIORef =<< newThemeScopes
  ctxSpanCache <- newIORef IM.empty
  ctxWidgetTextCache <- newIORef IM.empty
  ctxLayoutCache <- newIORef Nothing
  ctxMetricGen <- newIORef 0
  ctxLastMetricSource <- newIORef Nothing
  ctxPaintFull <- newIORef True
  let fm0 = Float -> FontMetrics
monospaceMetrics Float
12
      ctx = Context
        { ctxNodeArena :: NodeArena
ctxNodeArena = NodeArena
nodeArena
        , ctxDrawArena :: DrawArena
ctxDrawArena = DrawArena
drawArena
        , IORef WidgetId
ctxHotId :: IORef WidgetId
ctxHotId :: IORef WidgetId
ctxHotId
        , IORef WidgetId
ctxLastHotId :: IORef WidgetId
ctxLastHotId :: IORef WidgetId
ctxLastHotId
        , IORef WidgetId
ctxActiveId :: IORef WidgetId
ctxActiveId :: IORef WidgetId
ctxActiveId
        , IORef WidgetId
ctxClickedId :: IORef WidgetId
ctxClickedId :: IORef WidgetId
ctxClickedId
        , IORef WidgetId
ctxReleaseClickedId :: IORef WidgetId
ctxReleaseClickedId :: IORef WidgetId
ctxReleaseClickedId
        , IORef (Maybe V2)
ctxPressPos :: IORef (Maybe V2)
ctxPressPos :: IORef (Maybe V2)
ctxPressPos
        , IORef (Maybe V2)
ctxRightPressPos :: IORef (Maybe V2)
ctxRightPressPos :: IORef (Maybe V2)
ctxRightPressPos
        , IORef WidgetId
ctxFocusId :: IORef WidgetId
ctxFocusId :: IORef WidgetId
ctxFocusId
        , IORef Bool
ctxFocusVisible :: IORef Bool
ctxFocusVisible :: IORef Bool
ctxFocusVisible
        , IORef WidgetStore
ctxStore :: IORef WidgetStore
ctxStore :: IORef WidgetStore
ctxStore
        , IORef DamageState
ctxDamageState :: IORef DamageState
ctxDamageState :: IORef DamageState
ctxDamageState
        , IORef OverlayState
ctxOverlayState :: IORef OverlayState
ctxOverlayState :: IORef OverlayState
ctxOverlayState
        , IORef AnimationState
ctxAnimationState :: IORef AnimationState
ctxAnimationState :: IORef AnimationState
ctxAnimationState
        , IORef ScrollState
ctxScrollState :: IORef ScrollState
ctxScrollState :: IORef ScrollState
ctxScrollState
        , IORef DrawingCacheState
ctxDrawingCache :: IORef DrawingCacheState
ctxDrawingCache :: IORef DrawingCacheState
ctxDrawingCache
        , IORef IdContext
ctxIdContext :: IORef IdContext
ctxIdContext :: IORef IdContext
ctxIdContext
        , ctxFontMetrics :: FontMetrics
ctxFontMetrics = FontMetrics
fm0
        , ctxMonoFontMetrics :: FontMetrics
ctxMonoFontMetrics = FontMetrics
fm0
        , ctxMeasureText :: Text -> IO (Float, Float)
ctxMeasureText = FontMetrics -> Text -> IO (Float, Float)
measureTextIO FontMetrics
fm0
        , ctxResolveFont :: Float
-> FontWeight -> FontStyle -> FontVariant -> IO (FontMetrics, Bool)
ctxResolveFont = Context
-> Float
-> FontWeight
-> FontStyle
-> FontVariant
-> IO (FontMetrics, Bool)
defaultResolveFont Context
ctx
        , ctxResolveMeasure :: Float
-> FontWeight
-> FontStyle
-> FontVariant
-> Text
-> IO (Float, Float)
ctxResolveMeasure = Context
-> Float
-> FontWeight
-> FontStyle
-> FontVariant
-> Text
-> IO (Float, Float)
defaultResolveMeasure Context
ctx
        , ctxMeasureCache :: Maybe (IORef (HashMap (Text, Float) (Float, Float)))
ctxMeasureCache = Maybe (IORef (HashMap (Text, Float) (Float, Float)))
forall a. Maybe a
Nothing
        , IORef (IntMap SpanCacheEntry)
ctxSpanCache :: IORef (IntMap SpanCacheEntry)
ctxSpanCache :: IORef (IntMap SpanCacheEntry)
ctxSpanCache
        , IORef (IntMap WidgetTextCacheEntry)
ctxWidgetTextCache :: IORef (IntMap WidgetTextCacheEntry)
ctxWidgetTextCache :: IORef (IntMap WidgetTextCacheEntry)
ctxWidgetTextCache
        , IORef (Maybe (LayoutCache, Size, Int))
ctxLayoutCache :: IORef (Maybe (LayoutCache, Size, Int))
ctxLayoutCache :: IORef (Maybe (LayoutCache, Size, Int))
ctxLayoutCache
        , IORef Int
ctxMetricGen :: IORef Int
ctxMetricGen :: IORef Int
ctxMetricGen
        , ctxMetricSource :: MetricSource
ctxMetricSource = MetricSource
InitialMetricSource
        , IORef (Maybe MetricSource)
ctxLastMetricSource :: IORef (Maybe MetricSource)
ctxLastMetricSource :: IORef (Maybe MetricSource)
ctxLastMetricSource
        , IORef Bool
ctxPaintFull :: IORef Bool
ctxPaintFull :: IORef Bool
ctxPaintFull
        , ctxExternalText :: Bool
ctxExternalText = Bool
False
        , IORef Theme
ctxTheme :: IORef Theme
ctxTheme :: IORef Theme
ctxTheme
        , IORef ThemeScopes
ctxThemeScopes :: IORef ThemeScopes
ctxThemeScopes :: IORef ThemeScopes
ctxThemeScopes
        , IORef [Int]
ctxContainerStack :: IORef [Int]
ctxContainerStack :: IORef [Int]
ctxContainerStack
        , IORef [FrameMsg]
ctxMessages :: IORef [FrameMsg]
ctxMessages :: IORef [FrameMsg]
ctxMessages
        , IORef (MutablePrimArray RealWorld WidgetId)
ctxFocusables :: IORef (MutablePrimArray RealWorld WidgetId)
ctxFocusables :: IORef (MutablePrimArray RealWorld WidgetId)
ctxFocusables
        , IORef Int
ctxFocusablesCount :: IORef Int
ctxFocusablesCount :: IORef Int
ctxFocusablesCount
        , SpanArena
ctxSpanBase :: SpanArena
ctxSpanBase :: SpanArena
ctxSpanBase
        , SpanArena
ctxSpanOverlay :: SpanArena
ctxSpanOverlay :: SpanArena
ctxSpanOverlay
        , IORef InteractionState
ctxInteractionState :: IORef InteractionState
ctxInteractionState :: IORef InteractionState
ctxInteractionState
        , ctxClipboardGet :: IO (Maybe Text)
ctxClipboardGet = Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
        , ctxClipboardSet :: Text -> IO Bool
ctxClipboardSet = \Text
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        , ImageAtlas
ctxImageAtlas :: ImageAtlas
ctxImageAtlas :: ImageAtlas
ctxImageAtlas
        , IORef (Maybe (IO ()))
ctxWakeLoop :: IORef (Maybe (IO ()))
ctxWakeLoop :: IORef (Maybe (IO ()))
ctxWakeLoop
        , IORef (Map TypeRep Dynamic)
ctxHost :: IORef (Map TypeRep Dynamic)
ctxHost :: IORef (Map TypeRep Dynamic)
ctxHost
        , IORef Layout
ctxDefaultLayout :: IORef Layout
ctxDefaultLayout :: IORef Layout
ctxDefaultLayout
        }
  pure ctx

newPixelHostContext :: IO Context
newPixelHostContext :: IO Context
newPixelHostContext = do
  ctx0 <- IO Context
newContext
  ctx <- enableMeasureCache ctx0
  withTheme (withExternalText (withFontMetrics ctx (monospaceMetrics 16)) True) defaultTheme

-- =============================================================================
-- Focus
-- =============================================================================

{-# INLINE getFocusId #-}
getFocusId :: Context -> IO WidgetId
getFocusId :: Context -> IO WidgetId
getFocusId Context
ctx = IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx)

-- | Whether the focused widget shows its focus ring: focus moved by keyboard
-- since the last pointer press.
{-# INLINE getFocusVisible #-}
getFocusVisible :: Context -> IO Bool
getFocusVisible :: Context -> IO Bool
getFocusVisible Context
ctx = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Context -> IORef Bool
ctxFocusVisible Context
ctx)

{-# INLINE getHotId #-}
getHotId :: Context -> IO WidgetId
getHotId :: Context -> IO WidgetId
getHotId Context
ctx = IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxHotId Context
ctx)

-- | Add @wid@ to this frame's keyboard focus order, unless it is declared in a
-- disabled scope.
registerFocusable :: Context -> WidgetId -> IO ()
registerFocusable :: Context -> WidgetId -> IO ()
registerFocusable Context
ctx WidgetId
wid = do
  scope <- NodeArena -> IO Int
getArenaScope (Context -> NodeArena
ctxNodeArena Context
ctx)
  when (scope .&. 1 == 0) $ do
    idx <- readIORef (ctxFocusablesCount ctx)
    arr <- readIORef (ctxFocusables ctx)
    cap <- getSizeofMutablePrimArray arr
    arr' <-
      if idx >= cap
        then do
          grown <- resizeMutablePrimArray arr (max 16 (cap * 2))
          writeIORef (ctxFocusables ctx) grown
          pure grown
        else pure arr
    writePrimArray arr' idx wid
    writeIORef (ctxFocusablesCount ctx) (idx + 1)

{-# INLINE getFocusables #-}
getFocusables :: Context -> IO [WidgetId]
getFocusables :: Context -> IO [WidgetId]
getFocusables Context
ctx = do
  count <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Context -> IORef Int
ctxFocusablesCount Context
ctx)
  arr <- readIORef (ctxFocusables ctx)
  forM [0 .. count - 1] (readPrimArray arr)