-- | The widget store: per-widget state in maps by value type, keyed by widget
-- id and 'Slot'.
module NanoUI.Store
  ( WidgetStore (..)
  , emptyWidgetStore
  , mirrorStoresChanged
  , bumpMirror
  , slotKey
  , Slot (..)
  , boolInt
  , intBool
  , anySelectOpen
  , isSelectOpen
  , setSelectOpen
  , closeSelects
  , ptrEq
  , eqByPtr
  )
where

import Data.Dynamic (Dynamic)
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)
import Data.Text (Text)
import Data.Word (Word64)
import qualified Data.IntMap.Strict as IM
import GHC.Exts (isTrue#, reallyUnsafePtrEquality#)
import NanoUI.Id (mix64)

-- | Physical-equality shortcut. Pointer equality implies value equality for
-- immutable values, so callers may use 'True' to skip a structural comparison
-- of a field the caller never rebuilt. 'False' only means \"compare properly\".
{-# INLINE ptrEq #-}
ptrEq :: a -> a -> Bool
ptrEq :: forall a. a -> a -> Bool
ptrEq a
a a
b = Int# -> Bool
isTrue# (a -> a -> Int#
forall a b. a -> b -> Int#
reallyUnsafePtrEquality# a
a a
b)

-- | '==' with a physical-equality fast path. Unchanged fields of a
-- record-updated store keep their identity, so whole-store comparisons become
-- cheap when only one map was rebuilt.
{-# INLINE eqByPtr #-}
eqByPtr :: Eq a => a -> a -> Bool
eqByPtr :: forall a. Eq a => a -> a -> Bool
eqByPtr a
a a
b = a -> a -> Bool
forall a. a -> a -> Bool
ptrEq a
a a
b Bool -> Bool -> Bool
|| a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b

-- | Dynamic values do not implement Eq, but we can verify equality via
-- pointer equality fast path followed by checking key structure and
-- pointer equality of each Dynamic element.
{-# INLINE eqDynMap #-}
eqDynMap :: IntMap Dynamic -> IntMap Dynamic -> Bool
eqDynMap :: IntMap Dynamic -> IntMap Dynamic -> Bool
eqDynMap IntMap Dynamic
a IntMap Dynamic
b =
  IntMap Dynamic -> IntMap Dynamic -> Bool
forall a. a -> a -> Bool
ptrEq IntMap Dynamic
a IntMap Dynamic
b
    Bool -> Bool -> Bool
|| (IntMap Dynamic -> Int
forall a. IntMap a -> Int
IM.size IntMap Dynamic
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IntMap Dynamic -> Int
forall a. IntMap a -> Int
IM.size IntMap Dynamic
b Bool -> Bool -> Bool
&& (Dynamic -> Dynamic -> Bool)
-> IntMap Dynamic -> IntMap Dynamic -> Bool
forall a b. (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
IM.isSubmapOfBy Dynamic -> Dynamic -> Bool
forall a. a -> a -> Bool
ptrEq IntMap Dynamic
a IntMap Dynamic
b)

-- | Widget state for every widget, in maps by value type. Same-type fields
-- that share a widget key use 'slotKey'.
data WidgetStore = WidgetStore
  { WidgetStore -> Word64
storeMirrorGen :: {-# UNPACK #-} !Word64
  , WidgetStore -> Int
storeOpenSelect :: {-# UNPACK #-} !Int
  , WidgetStore -> IntMap Int
storeInt :: !(IntMap Int)
  , WidgetStore -> IntMap Float
storeFloat :: !(IntMap Float)
  , WidgetStore -> IntMap Double
storeDouble :: !(IntMap Double)
  , WidgetStore -> IntMap (Float, Float)
storePoint :: !(IntMap (Float, Float))
  , WidgetStore -> IntMap Text
storeText :: !(IntMap Text)
  , WidgetStore -> IntMap IntSet
storeIntSet :: !(IntMap IntSet)
  , WidgetStore -> IntMap [Float]
storeFloatList :: !(IntMap [Float])
  , WidgetStore -> IntMap [Int]
storeIntList :: !(IntMap [Int])
  , WidgetStore -> IntMap Dynamic
storeDyn :: !(IntMap Dynamic)
  }

instance Eq WidgetStore where
  WidgetStore
a == :: WidgetStore -> WidgetStore -> Bool
== WidgetStore
b =
    WidgetStore -> Word64
storeMirrorGen WidgetStore
a Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetStore -> Word64
storeMirrorGen WidgetStore
b
      Bool -> Bool -> Bool
&& WidgetStore -> Int
storeOpenSelect WidgetStore
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetStore -> Int
storeOpenSelect WidgetStore
b
      Bool -> Bool -> Bool
&& IntMap Int -> IntMap Int -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap Int
storeInt WidgetStore
a) (WidgetStore -> IntMap Int
storeInt WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap Float -> IntMap Float -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap Float
storeFloat WidgetStore
a) (WidgetStore -> IntMap Float
storeFloat WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap Double -> IntMap Double -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap Double
storeDouble WidgetStore
a) (WidgetStore -> IntMap Double
storeDouble WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap (Float, Float) -> IntMap (Float, Float) -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
a) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap Text -> IntMap Text -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap Text
storeText WidgetStore
a) (WidgetStore -> IntMap Text
storeText WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap IntSet -> IntMap IntSet -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap IntSet
storeIntSet WidgetStore
a) (WidgetStore -> IntMap IntSet
storeIntSet WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap [Float] -> IntMap [Float] -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap [Float]
storeFloatList WidgetStore
a) (WidgetStore -> IntMap [Float]
storeFloatList WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap [Int] -> IntMap [Int] -> Bool
forall a. Eq a => a -> a -> Bool
eqByPtr (WidgetStore -> IntMap [Int]
storeIntList WidgetStore
a) (WidgetStore -> IntMap [Int]
storeIntList WidgetStore
b)
      Bool -> Bool -> Bool
&& IntMap Dynamic -> IntMap Dynamic -> Bool
eqDynMap (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
a) (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
b)

instance Show WidgetStore where
  show :: WidgetStore -> String
show WidgetStore
st =
    String
"WidgetStore { "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"storeMirrorGen = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (WidgetStore -> Word64
storeMirrorGen WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeOpenSelect = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (WidgetStore -> Int
storeOpenSelect WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeInt = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap Int -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap Int
storeInt WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeFloat = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap Float -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap Float
storeFloat WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeDouble = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap Double -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap Double
storeDouble WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storePoint = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap (Float, Float) -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeText = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap Text -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap Text
storeText WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeIntSet = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap IntSet -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap IntSet
storeIntSet WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeFloatList = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap [Float] -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap [Float]
storeFloatList WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeIntList = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntMap [Int] -> String
forall a. Show a => a -> String
show (WidgetStore -> IntMap [Int]
storeIntList WidgetStore
st)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", storeDynCount = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (IntMap Dynamic -> Int
forall a. IntMap a -> Int
IM.size (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
st))
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"

emptyWidgetStore :: WidgetStore
emptyWidgetStore :: WidgetStore
emptyWidgetStore =
  WidgetStore
    { storeMirrorGen :: Word64
storeMirrorGen = Word64
0
    , storeOpenSelect :: Int
storeOpenSelect = Int
0
    , storeInt :: IntMap Int
storeInt = IntMap Int
forall a. IntMap a
IM.empty
    , storeFloat :: IntMap Float
storeFloat = IntMap Float
forall a. IntMap a
IM.empty
    , storeDouble :: IntMap Double
storeDouble = IntMap Double
forall a. IntMap a
IM.empty
    , storePoint :: IntMap (Float, Float)
storePoint = IntMap (Float, Float)
forall a. IntMap a
IM.empty
    , storeText :: IntMap Text
storeText = IntMap Text
forall a. IntMap a
IM.empty
    , storeIntSet :: IntMap IntSet
storeIntSet = IntMap IntSet
forall a. IntMap a
IM.empty
    , storeFloatList :: IntMap [Float]
storeFloatList = IntMap [Float]
forall a. IntMap a
IM.empty
    , storeIntList :: IntMap [Int]
storeIntList = IntMap [Int]
forall a. IntMap a
IM.empty
    , storeDyn :: IntMap Dynamic
storeDyn = IntMap Dynamic
forall a. IntMap a
IM.empty
    }

-- useText/useFlag bump this so Frame can re-run UI without watching every map.
{-# INLINE mirrorStoresChanged #-}
mirrorStoresChanged :: WidgetStore -> WidgetStore -> Bool
mirrorStoresChanged :: WidgetStore -> WidgetStore -> Bool
mirrorStoresChanged WidgetStore
old WidgetStore
new = WidgetStore -> Word64
storeMirrorGen WidgetStore
old Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= WidgetStore -> Word64
storeMirrorGen WidgetStore
new

{-# INLINE bumpMirror #-}
bumpMirror :: WidgetStore -> WidgetStore
bumpMirror :: WidgetStore -> WidgetStore
bumpMirror WidgetStore
st = WidgetStore
st {storeMirrorGen = storeMirrorGen st + 1}

-- Mix a field tag into a widget key so two Ints (cursor vs anchor) do not collide.
{-# INLINE slotKey #-}
slotKey :: Slot -> Int -> Int
slotKey :: Slot -> Int -> Int
slotKey Slot
s Int
k = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64 -> Word64
mix64 (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) (Slot -> Word64
slotTag Slot
s))

-- | Every built-in slot.
data Slot
  = SlotCursor
  | SlotAnchor
  | SlotDrag
  | SlotDragW
  | SlotDrop
  | SlotDropPos
  | SlotWinSize
  | SlotMenuOpen
  | SlotMenuPos
  | SlotScrollCfg
  | SlotScrollOff
  | SlotScrollCross
  | SlotScrollLinkX
  | SlotScrollLinkY
  | SlotScrollStep
  | SlotScrollAxes
  | SlotScrollViewPos
  | SlotScrollViewSize
  | SlotScrollRange
  | SlotScrollContent
  | SlotTextAreaRow
  | SlotTextAreaCol
  | SlotTextAreaPrefCol
  | SlotTextAreaScroll
  | SlotTextAreaViewport
  | SlotTextAreaAnchorRow
  | SlotTextAreaAnchorCol
  | -- | Cached text-area content extent (max line width, line count * line
    -- height) and the node font size they were measured at. Recomputing the width
    -- scans every character of the document, so it is cached and only refreshed
    -- when the text or font changes.
    SlotTextAreaContentW
  | SlotTextAreaContentH
  | SlotTextAreaContentFont
  | -- | Cached 'TextBuffer' for the text area, keyed by its flat 'Text'. Loads and
    -- paint reuse it so the document is not re-split into lines every call.
    SlotTextAreaBuffer
  | -- | Set (value 1) to signal that the text area's text changed through a path
    -- that does not flow through 'Input' (e.g. a context-menu cut/paste). The
    -- text area widget reads and clears this on its next frame, so the caller
    -- still gets a 'respChanged' pulse for edits that carry no keys or chars.
    SlotTextAreaChanged
  | -- | A text field's undo history with the text it was recorded against, in
    -- 'storeDyn'.
    SlotTextHistory
  | -- | Which kind of text field a widget id is: 1 single-line, 2 multi-line.
    -- Commands sent to the id between frames read it.
    SlotTextMode
  | -- | A text area's measured line widths, in 'storeDyn', kept in step with its
    -- lines so an edit remeasures only the lines it changed.
    SlotTextAreaWidths
  | SlotTextInputScroll
  | -- | Search-field debounce bookkeeping. Text slots on the text widget id: the last
    -- committed query and the monotonic timestamp of the last edit.
    SlotSearchCommitted
  | SlotSearchAge
  | -- | Combo box suggestion state (storeInt/storeFloat, keyed by the field
    -- widget): the highlighted option index (absolute into the filtered list),
    -- the start of the visible window slice (keyboard / wheel / scrollbar
    -- scrolling), and the scrollbar bookkeeping the overlay painter and the
    -- widget's thumb-drag gesture share (total filtered count, widest row, x
    -- offset, drag axis + grab offset).
    SlotComboHighlight
  | SlotComboScroll
  | SlotComboCount
  | SlotComboScrollX
  | SlotComboContentW
  | SlotComboDrag
  | SlotComboDragOff
  | -- | The last committed value (storeText): typing edits the live field text but
    -- only Enter, a row click, or losing focus commits it (Escape reverts).
    SlotComboCommitted
  | -- | Had-focus flag (storeInt) so the widget can see the focus-lost transition
    -- on the frame after blur and commit then.
    SlotComboFocus
  | -- | The field text as the widget last produced it (storeText): a frame-start
    -- value that differs from it changed externally (a frame-side row pick or a
    -- clipboard menu action), not by typing.
    SlotComboLive
  | -- | PaneGrid gesture slot (storeInt): 0 none, positive = dragged pane id,
    -- negative = split id being resized. Mirrors 'SlotDrag''s press-held-release
    -- lifecycle but keyed by the grid widget instead of a per-pane leaf.
    SlotPaneGest
  | -- | PaneGrid drag grab offset (storePoint): (mouse - pane origin) at grab start.
    SlotPaneGrab
  | -- | PaneGrid keyboard-navigation focus: focused pane id (0 = none, auto-first).
    SlotPaneFocus
  | -- | PaneGrid maximize state: maximized pane id (0 = none).
    SlotPaneMax
  | -- | PaneGrid resize start (storePoint): (ratio, main-axis mouse) captured when a
    -- divider is first grabbed, so dragging moves it by delta rather than snapping.
    SlotPaneResize
  | -- | PaneGrid id seed (storeInt): next split / pane id to allocate. Strictly
    -- monotonic per grid: ids are never reused, so per-pane state keyed by pane
    -- id cannot collide with a closed pane's state.
    SlotPaneNext
  | -- | The value a controlled widget last returned to its caller.
    SlotSeen
  | -- | A colour picker's opening colour.
    SlotColorBase
  | -- | The stepper arrow a numeric field's press holds: 1 up, -1 down.
    SlotNumericHeld
  | -- | When a numeric field's held stepper arrow next repeats, in monotonic
    -- seconds.
    SlotNumericRepeat
  deriving (Int -> Slot
Slot -> Int
Slot -> [Slot]
Slot -> Slot
Slot -> Slot -> [Slot]
Slot -> Slot -> Slot -> [Slot]
(Slot -> Slot)
-> (Slot -> Slot)
-> (Int -> Slot)
-> (Slot -> Int)
-> (Slot -> [Slot])
-> (Slot -> Slot -> [Slot])
-> (Slot -> Slot -> [Slot])
-> (Slot -> Slot -> Slot -> [Slot])
-> Enum Slot
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Slot -> Slot
succ :: Slot -> Slot
$cpred :: Slot -> Slot
pred :: Slot -> Slot
$ctoEnum :: Int -> Slot
toEnum :: Int -> Slot
$cfromEnum :: Slot -> Int
fromEnum :: Slot -> Int
$cenumFrom :: Slot -> [Slot]
enumFrom :: Slot -> [Slot]
$cenumFromThen :: Slot -> Slot -> [Slot]
enumFromThen :: Slot -> Slot -> [Slot]
$cenumFromTo :: Slot -> Slot -> [Slot]
enumFromTo :: Slot -> Slot -> [Slot]
$cenumFromThenTo :: Slot -> Slot -> Slot -> [Slot]
enumFromThenTo :: Slot -> Slot -> Slot -> [Slot]
Enum)

-- | Tag for a built-in slot: the constructor index mixed with a salt, so tags
-- are well spread.
{-# INLINE slotTag #-}
slotTag :: Slot -> Word64
slotTag :: Slot -> Word64
slotTag Slot
s = Word64 -> Word64 -> Word64
mix64 Word64
0x534C4F5454414753 (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Slot -> Int
forall a. Enum a => a -> Int
fromEnum Slot
s))

boolInt :: Bool -> Int
boolInt :: Bool -> Int
boolInt Bool
b = if Bool
b then Int
1 else Int
0

intBool :: Int -> Bool
intBool :: Int -> Bool
intBool Int
n = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

-- One open select at a time.
{-# INLINE anySelectOpen #-}
anySelectOpen :: WidgetStore -> Bool
anySelectOpen :: WidgetStore -> Bool
anySelectOpen WidgetStore
st = WidgetStore -> Int
storeOpenSelect WidgetStore
st Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

{-# INLINE isSelectOpen #-}
isSelectOpen :: WidgetStore -> Int -> Bool
isSelectOpen :: WidgetStore -> Int -> Bool
isSelectOpen WidgetStore
st Int
k = Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& WidgetStore -> Int
storeOpenSelect WidgetStore
st Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k

{-# INLINE setSelectOpen #-}
setSelectOpen :: WidgetStore -> Int -> Bool -> WidgetStore
setSelectOpen :: WidgetStore -> Int -> Bool -> WidgetStore
setSelectOpen WidgetStore
st Int
k Bool
True = WidgetStore
st {storeOpenSelect = k}
setSelectOpen WidgetStore
st Int
k Bool
False
  | WidgetStore -> Int -> Bool
isSelectOpen WidgetStore
st Int
k = WidgetStore -> WidgetStore
closeSelects WidgetStore
st
  | Bool
otherwise = WidgetStore
st

{-# INLINE closeSelects #-}
closeSelects :: WidgetStore -> WidgetStore
closeSelects :: WidgetStore -> WidgetStore
closeSelects WidgetStore
st = WidgetStore
st {storeOpenSelect = 0}