{-# LANGUAGE DataKinds #-}

module NanoUI.Frame.Cursor
  ( UiCursorKind (..)
  , uiCursorKind
  , pointerCursorWanted
  , cursorKindIs
  ) where

import Data.IORef (readIORef)
import qualified Data.IntMap.Strict as IM
import Data.Maybe (fromMaybe, isJust)
import NanoUI.Context
  ( Context (..)
  , CustomDrawContext (..)
  , WidgetStore (..)
  , getFocusId
  , getHotId
  , getScrollDrag
  , getStore
  , intKey
  , isDisabled
  , isSelectOpen
  , lookupCustomCursor
  , widgetTheme
  , getsInteraction
  , InteractionState (..)
  )
import NanoUI.Font (FontMetrics, sliderHandleSlack, sliderTrackBounds)
import NanoUI.Frame.Hit (findNodeByWidgetId, nodePointVisible, scrollHitRect)
import NanoUI.Frame.Scroll (ScrollBarLayout (..), scrollBarsFor)
import NanoUI.Frame.Select (overlayMenuOwnerAt, selectDropRect)
import NanoUI.Frame.TextArea.Content (isMouseOnTextAreaScrollBarAt)
import NanoUI.Frame.TextEdit.Menu (textEditMenuCursorKind, textFieldWidgetAtMouse)
import NanoUI.Frame.TextInput (nodeTextFieldGeom, searchClearHit)
import NanoUI.Frame.Window (windowResizeCursorKind)
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input
  ( Input (..)
  , UiCursorKind (..)
  , grabDragKind
  , grabHoverKind
  , inputMouseDown
  , inputMousePos
  )
import NanoUI.Layout.Arena
  ( DirTag (..)
  , NodeIdx
  , NodeType (..)
  , findChildM
  , findNodeM
  , getDirection
  , getNodeType
  , getOptions
  , getParent
  , getRect
  , getStyleIdx
  , getWidgetId
  , isScrollNode
  )
import NanoUI.Types (Rect (..), V2 (..), rectContains)
import NanoUI.WidgetText (numericStepperRects, textInputNumericMode)
import NanoUI.WidgetText (isTableHeaderStyle)

uiCursorKind :: Context -> Input -> IO UiCursorKind
uiCursorKind :: Context -> Input -> IO UiCursorKind
uiCursorKind Context
ctx Input
inp = do
  -- The first query with an opinion wins; later ones do not run.
  mKind <-
    (IO (Maybe UiCursorKind)
 -> IO (Maybe UiCursorKind) -> IO (Maybe UiCursorKind))
-> IO (Maybe UiCursorKind)
-> [IO (Maybe UiCursorKind)]
-> IO (Maybe UiCursorKind)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\IO (Maybe UiCursorKind)
query IO (Maybe UiCursorKind)
rest -> IO (Maybe UiCursorKind)
query IO (Maybe UiCursorKind)
-> (Maybe UiCursorKind -> IO (Maybe UiCursorKind))
-> IO (Maybe UiCursorKind)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe UiCursorKind)
-> (UiCursorKind -> IO (Maybe UiCursorKind))
-> Maybe UiCursorKind
-> IO (Maybe UiCursorKind)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (Maybe UiCursorKind)
rest (Maybe UiCursorKind -> IO (Maybe UiCursorKind)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UiCursorKind -> IO (Maybe UiCursorKind))
-> (UiCursorKind -> Maybe UiCursorKind)
-> UiCursorKind
-> IO (Maybe UiCursorKind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UiCursorKind -> Maybe UiCursorKind
forall a. a -> Maybe a
Just))
      (Maybe UiCursorKind -> IO (Maybe UiCursorKind)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UiCursorKind
forall a. Maybe a
Nothing)
      [ Context -> Input -> IO (Maybe UiCursorKind)
textEditMenuCursorKind Context
ctx Input
inp
      , Context -> Input -> IO (Maybe UiCursorKind)
selectDropdownCursorKind Context
ctx Input
inp
      , Context -> Input -> IO (Maybe UiCursorKind)
windowResizeCursorKind Context
ctx Input
inp
      , Context -> Input -> IO (Maybe UiCursorKind)
tableColResizeCursorKind Context
ctx Input
inp
      , Context -> Input -> IO (Maybe UiCursorKind)
scrollThumbCursorKind Context
ctx Input
inp
      , Context -> Input -> IO (Maybe UiCursorKind)
textFieldHoverCursorKind Context
ctx Input
inp
      ]
  case mKind of
    Just UiCursorKind
k -> UiCursorKind -> IO UiCursorKind
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UiCursorKind
k
    Maybe UiCursorKind
Nothing -> do
      let mouse :: V2
mouse = Input -> V2
inputMousePos Input
inp
      active <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxActiveId Context
ctx)
      activeKind <- cursorKindAt ctx active mouse inp
      if activeKind /= UiCursorDefault
        then pure activeKind
        else do
          hot <- getHotId ctx
          cursorKindAt ctx hot mouse inp

selectDropdownCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
selectDropdownCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
selectDropdownCursorKind Context
ctx Input
inp = do
  let mouse :: V2
mouse = Input -> V2
inputMousePos Input
inp
      na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  dropPress <- Context -> (InteractionState -> Bool) -> IO Bool
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Bool
isSelectDropPress
  store <- getStore ctx
  mSel <-
    findNodeM na $ \NodeIdx
idx -> do
      nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
      if nt /= NodeSelect
        then pure False
        else do
          wid <- getWidgetId na idx
          opts <- getOptions na idx
          (x, y, w, h) <- getRect na idx
          let dropRect = Float -> Float -> Float -> Float -> NodeIdx -> Rect
selectDropRect Float
x Float
y Float
w Float
h ([Text] -> NodeIdx
forall a. [a] -> NodeIdx
forall (t :: * -> *) a. Foldable t => t a -> NodeIdx
length [Text]
opts)
          pure ((isSelectOpen store (intKey wid) || dropPress) && rectContains dropRect mouse)
  if isJust mSel
    then pure (Just UiCursorPointer)
    else
      -- A focused combo's dropdown (visible while its field holds focus) is
      -- not a select: pointer over its menu like the select's. The text-input
      -- menu case inside overlayMenuOwnerAt is unreachable here, since
      -- textEditMenuCursorKind runs first in uiCursorKind.
      (UiCursorPointer <$) <$> overlayMenuOwnerAt ctx mouse

scrollThumbCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
scrollThumbCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
scrollThumbCursorKind Context
ctx Input
inp = do
  mDrag <- Context -> IO (Maybe (WidgetId, DirTag, Float))
getScrollDrag Context
ctx
  if inputMouseDown inp && isJust mDrag
    then pure (Just UiCursorGrabbing)
    else do
      onThumb <- scrollThumbHit ctx (inputMousePos inp)
      pure (if onThumb then Just (grabHoverKind True inp) else Nothing)

-- Field well, not the label. Independent of focus and hot. A search field's
-- clear button raises the pointer cursor; everywhere else over a field is text.
textFieldHoverCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
textFieldHoverCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
textFieldHoverCursorKind Context
ctx Input
inp = do
  let mouse :: V2
mouse = Input -> V2
inputMousePos Input
inp
  mWid <- Context -> V2 -> IO (Maybe WidgetId)
textFieldWidgetAtMouse Context
ctx V2
mouse
  case mWid of
    Maybe WidgetId
Nothing -> Maybe UiCursorKind -> IO (Maybe UiCursorKind)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UiCursorKind
forall a. Maybe a
Nothing
    Just WidgetId
wid -> do
      onClear <- Context -> WidgetId -> V2 -> IO Bool
searchClearHit Context
ctx WidgetId
wid V2
mouse
      onStepper <- numericStepperHit ctx wid mouse
      pure (Just (if onClear || onStepper then UiCursorPointer else UiCursorText))

-- | Whether the pointer is over a numeric field's stepper, which takes the
-- pointer cursor rather than the text cursor.
numericStepperHit :: Context -> WidgetId -> V2 -> IO Bool
numericStepperHit :: Context -> WidgetId -> V2 -> IO Bool
numericStepperHit Context
ctx WidgetId
wid V2
mouse =
  Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid IO (Maybe NodeIdx) -> (Maybe NodeIdx -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe NodeIdx
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just NodeIdx
idx -> do
      si <- NodeArena -> NodeIdx -> IO NodeIdx
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
      if not (textInputNumericMode si)
        then pure False
        else do
          (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
          let (up, down) = numericStepperRects x y w h
          pure (rectContains up mouse || rectContains down mouse)

scrollThumbHit :: Context -> V2 -> IO Bool
scrollThumbHit :: Context -> V2 -> IO Bool
scrollThumbHit Context
ctx V2
mouse =
  (Maybe NodeIdx -> Bool) -> IO (Maybe NodeIdx) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe NodeIdx -> Bool
forall a. Maybe a -> Bool
isJust (IO (Maybe NodeIdx) -> IO Bool)
-> ((NodeIdx -> IO Bool) -> IO (Maybe NodeIdx))
-> (NodeIdx -> IO Bool)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findNodeM NodeArena
na ((NodeIdx -> IO Bool) -> IO Bool)
-> (NodeIdx -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \NodeIdx
idx -> do
    nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
    if nt /= NodeTextArea && not (isScrollNode nt)
      then pure False
      else do
        wid <- getWidgetId na idx
        any (\(DirTag
_, ScrollBarLayout
layout, Float -> IO ()
_) -> Rect -> V2 -> Bool
rectContains (ScrollBarLayout -> Rect
sbThumb ScrollBarLayout
layout) V2
mouse) <$> scrollBarsFor ctx idx wid
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx

cursorKindAt :: Context -> WidgetId -> V2 -> Input -> IO UiCursorKind
cursorKindAt :: Context -> WidgetId -> V2 -> Input -> IO UiCursorKind
cursorKindAt Context
ctx WidgetId
wid V2
mouse Input
inp
  | WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = UiCursorKind -> IO UiCursorKind
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UiCursorKind
UiCursorDefault
  | Bool
otherwise = do
      disabled <- Context -> WidgetId -> IO Bool
isDisabled Context
ctx WidgetId
wid
      if disabled
        then pure UiCursorDefault
        else do
          mCursorFn <- lookupCustomCursor ctx wid
          case mCursorFn of
            Just CustomDrawContext -> UiCursorKind
cursorFn -> do
              visible <- Context -> WidgetId -> V2 -> IO Bool
widgetVisibleAt Context
ctx WidgetId
wid V2
mouse
              if not visible
                then pure UiCursorDefault
                else do
                  active <- readIORef (ctxActiveId ctx)
                  hot <- getHotId ctx
                  focused <- (== wid) <$> getFocusId ctx
                  theme <- widgetTheme ctx wid
                  let cdc =
                        CustomDrawContext
                          { cdcHovered :: Bool
cdcHovered = WidgetId
hot WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
                          , cdcPressed :: Bool
cdcPressed = WidgetId
active WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
                          , cdcFocused :: Bool
cdcFocused = Bool
focused
                          , cdcActive :: Bool
cdcActive = WidgetId
active WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
                          , cdcDisabled :: Bool
cdcDisabled = Bool
disabled
                          , cdcTheme :: Theme
cdcTheme = Theme
theme
                          , cdcFont :: FontMetrics
cdcFont = Context -> FontMetrics
ctxFontMetrics Context
ctx
                          }
                  pure (cursorFn cdc)
            Maybe (CustomDrawContext -> UiCursorKind)
Nothing -> do
              -- Resolve the node through the arena's id index rather than
              -- building a type table of every widget for two lookups.
              mNodeType <- Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid IO (Maybe NodeIdx)
-> (Maybe NodeIdx -> IO (Maybe NodeType)) -> IO (Maybe NodeType)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (NodeIdx -> IO NodeType) -> Maybe NodeIdx -> IO (Maybe NodeType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (NodeArena -> NodeIdx -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx))
              case mNodeType of
                Just NodeType
NodeButton -> Context -> WidgetId -> V2 -> IO UiCursorKind
widgetPointerCursor Context
ctx WidgetId
wid V2
mouse
                Just NodeType
NodeCheckbox -> Context -> WidgetId -> V2 -> IO UiCursorKind
widgetPointerCursor Context
ctx WidgetId
wid V2
mouse
                Just NodeType
NodeRadio -> Context -> WidgetId -> V2 -> IO UiCursorKind
widgetPointerCursor Context
ctx WidgetId
wid V2
mouse
                Just NodeType
NodeTree -> Context -> WidgetId -> V2 -> IO UiCursorKind
widgetPointerCursor Context
ctx WidgetId
wid V2
mouse
                Just NodeType
NodeSelect -> Context -> WidgetId -> V2 -> IO UiCursorKind
selectCursorKind Context
ctx WidgetId
wid V2
mouse
                Just NodeType
NodeColorPicker -> UiCursorKind -> IO UiCursorKind
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UiCursorKind
UiCursorPointer
                Just NodeType
NodeTextInput -> Context -> WidgetId -> V2 -> IO UiCursorKind
textInputCursorKind Context
ctx WidgetId
wid V2
mouse
                Just NodeType
NodeTextArea -> Context -> WidgetId -> V2 -> IO UiCursorKind
textAreaCursorKind Context
ctx WidgetId
wid V2
mouse
                Just NodeType
NodeSlider -> Context -> WidgetId -> V2 -> Input -> IO UiCursorKind
sliderCursorKind Context
ctx WidgetId
wid V2
mouse Input
inp
                Maybe NodeType
_ -> UiCursorKind -> IO UiCursorKind
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UiCursorKind
UiCursorDefault

selectCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind
selectCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind
selectCursorKind Context
ctx WidgetId
wid V2
mouse = do
  visible <- Context -> WidgetId -> V2 -> IO Bool
widgetVisibleAt Context
ctx WidgetId
wid V2
mouse
  if not visible
    then pure UiCursorDefault
    else do
      mrect <- scrollHitRect ctx wid
      pure (if maybe False (`rectContains` mouse) mrect then UiCursorPointer else UiCursorDefault)

widgetVisibleAt :: Context -> WidgetId -> V2 -> IO Bool
widgetVisibleAt :: Context -> WidgetId -> V2 -> IO Bool
widgetVisibleAt Context
ctx WidgetId
wid V2
mouse = do
  mIdx <- Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid
  case mIdx of
    Maybe NodeIdx
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just NodeIdx
idx -> Context -> NodeIdx -> V2 -> IO Bool
nodePointVisible Context
ctx NodeIdx
idx V2
mouse

widgetPointerCursor :: Context -> WidgetId -> V2 -> IO UiCursorKind
widgetPointerCursor :: Context -> WidgetId -> V2 -> IO UiCursorKind
widgetPointerCursor Context
ctx WidgetId
wid V2
mouse = do
  visible <- Context -> WidgetId -> V2 -> IO Bool
widgetVisibleAt Context
ctx WidgetId
wid V2
mouse
  pure (if visible then UiCursorPointer else UiCursorDefault)

sliderCursorKind :: Context -> WidgetId -> V2 -> Input -> IO UiCursorKind
sliderCursorKind :: Context -> WidgetId -> V2 -> Input -> IO UiCursorKind
sliderCursorKind Context
ctx WidgetId
wid V2
mouse Input
inp = do
  active <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxActiveId Context
ctx)
  if active == wid && inputMouseDown inp
    then pure UiCursorGrabbing
    else do
      visible <- widgetVisibleAt ctx wid mouse
      if not visible
        then pure UiCursorDefault
        else do
          mrect <- scrollHitRect ctx wid
          pure $
            case mrect of
              Maybe Rect
Nothing -> UiCursorKind
UiCursorDefault
              Just (Rect Float
x Float
y Float
w Float
h) ->
                let Rect Float
tx Float
ty Float
tw Float
th = Float -> Float -> Float -> Float -> Rect
sliderTrackBounds Float
x Float
y Float
w Float
h
                    hitRect :: Rect
hitRect = Float -> Float -> Float -> Float -> Rect
Rect Float
tx (Float
ty Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
sliderHandleSlack) Float
tw (Float
th Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
sliderHandleSlack)
                 in Bool -> Bool -> Input -> UiCursorKind
grabDragKind (Rect -> V2 -> Bool
rectContains Rect
hitRect V2
mouse) Bool
False Input
inp

textInputCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind
textInputCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind
textInputCursorKind Context
ctx WidgetId
wid V2
mouse = do
  visible <- Context -> WidgetId -> V2 -> IO Bool
widgetVisibleAt Context
ctx WidgetId
wid V2
mouse
  if not visible
    then pure UiCursorDefault
    else do
      mIdx <- findNodeByWidgetId ctx wid
      mrect <- scrollHitRect ctx wid
      case (mIdx, mrect) of
        (Just NodeIdx
idx, Just (Rect Float
x Float
y Float
w Float
h)) -> do
          (field, _) <- Context
-> NodeIdx -> Float -> Float -> Float -> Float -> IO (Rect, Rect)
nodeTextFieldGeom Context
ctx NodeIdx
idx Float
x Float
y Float
w Float
h
          onStepper <- numericStepperHit ctx wid mouse
          pure $
            if onStepper
              then UiCursorPointer
              else if rectContains field mouse then UiCursorText else UiCursorDefault
        (Maybe NodeIdx, Maybe Rect)
_ -> UiCursorKind -> IO UiCursorKind
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UiCursorKind
UiCursorDefault

textAreaCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind
textAreaCursorKind :: Context -> WidgetId -> V2 -> IO UiCursorKind
textAreaCursorKind Context
ctx WidgetId
wid V2
mouse = do
  mIdx <- Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid
  case mIdx of
    Maybe NodeIdx
Nothing -> UiCursorKind -> IO UiCursorKind
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UiCursorKind
UiCursorDefault
    Just NodeIdx
idx -> do
      onScroll <- Context -> NodeIdx -> V2 -> IO Bool
isMouseOnTextAreaScrollBarAt Context
ctx NodeIdx
idx V2
mouse
      if onScroll
        then pure UiCursorDefault
        else
          textFieldCursorKind ctx wid mouse $ \FontMetrics
_ Float
x Float
y Float
w Float
h ->
            Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h

textFieldCursorKind ::
  Context ->
  WidgetId ->
  V2 ->
  (FontMetrics -> Float -> Float -> Float -> Float -> Rect) ->
  IO UiCursorKind
textFieldCursorKind :: Context
-> WidgetId
-> V2
-> (FontMetrics -> Float -> Float -> Float -> Float -> Rect)
-> IO UiCursorKind
textFieldCursorKind Context
ctx WidgetId
wid V2
mouse FontMetrics -> Float -> Float -> Float -> Float -> Rect
fieldAt = do
  visible <- Context -> WidgetId -> V2 -> IO Bool
widgetVisibleAt Context
ctx WidgetId
wid V2
mouse
  if not visible
    then pure UiCursorDefault
    else do
      mrect <- scrollHitRect ctx wid
      pure $
        case mrect of
          Just (Rect Float
x Float
y Float
w Float
h)
            | Rect -> V2 -> Bool
rectContains (FontMetrics -> Float -> Float -> Float -> Float -> Rect
fieldAt (Context -> FontMetrics
ctxFontMetrics Context
ctx) Float
x Float
y Float
w Float
h) V2
mouse -> UiCursorKind
UiCursorText
          Maybe Rect
_ -> UiCursorKind
UiCursorDefault

tableColResizeCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
tableColResizeCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
tableColResizeCursorKind Context
ctx Input
inp = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let dragging = (NodeIdx -> Bool) -> [NodeIdx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\NodeIdx
n -> NodeIdx
n NodeIdx -> NodeIdx -> Bool
forall a. Ord a => a -> a -> Bool
<= -NodeIdx
1000 Bool -> Bool -> Bool
&& NodeIdx
n NodeIdx -> NodeIdx -> Bool
forall a. Ord a => a -> a -> Bool
> -NodeIdx
2000) (IntMap NodeIdx -> [NodeIdx]
forall a. IntMap a -> [a]
IM.elems (WidgetStore -> IntMap NodeIdx
storeInt WidgetStore
store))
      na = Context -> NodeArena
ctxNodeArena Context
ctx
      V2 mx my = inputMousePos inp
  if inputMouseDown inp && dragging
    then pure (Just UiCursorEwResize)
    else do
      mEdge <-
        findNodeM na $ \NodeIdx
idx -> do
          nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
          if nt /= NodeButton
            then pure False
            else do
              si <- getStyleIdx na idx
              if not (isTableHeaderStyle si)
                then pure False
                else do
                  (x, y, w, h) <- getRect na idx
                  -- The resize cursor spans the whole column height
                  -- (header plus body cells down to the body
                  -- scroller's bottom edge), matching the drag grab
                  -- zone: tableBodyScrollerBottom locates the same
                  -- body scroller whose rect the grab zone anchors
                  -- on (its prev-frame value, readable at build
                  -- time), so the two zones cannot disagree.
                  yBot <- fromMaybe (y + h) <$> tableBodyScrollerBottom ctx idx
                  pure (my >= y && my <= yBot && abs (mx - (x + w)) <= 4 && w > 0 && h > 0)
      pure (UiCursorEwResize <$ mEdge)

-- | Bottom edge of a table's body scroller, located structurally from one
-- of its header buttons: walk up to the first ancestor that has a direct
-- Column-direction scroll-container child (the pane column built by
-- tableSplitPanes) and take that child's rect bottom. Runs post-solve, so
-- the rect is current-frame. Nothing when no such scroller exists (the
-- caller falls back to the header button's own bottom).
tableBodyScrollerBottom :: Context -> NodeIdx -> IO (Maybe Float)
tableBodyScrollerBottom :: Context -> NodeIdx -> IO (Maybe Float)
tableBodyScrollerBottom Context
ctx = NodeIdx -> IO (Maybe Float)
goUp
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    goUp :: NodeIdx -> IO (Maybe Float)
goUp NodeIdx
i = do
      p <- NodeArena -> NodeIdx -> IO NodeIdx
getParent NodeArena
na NodeIdx
i
      if p < 0
        then pure Nothing
        else do
          mScroller <-
            findChildM na p $ \NodeIdx
c -> do
              nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
c
              if isScrollNode nt
                then (== DirColumn) <$> getDirection na c
                else pure False
          case mScroller of
            Just NodeIdx
sc -> do
              (_, sy, _, sh) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect NodeArena
na NodeIdx
sc
              pure (Just (sy + sh))
            Maybe NodeIdx
Nothing -> NodeIdx -> IO (Maybe Float)
goUp NodeIdx
p

pointerCursorWanted :: Context -> Input -> IO Bool
pointerCursorWanted :: Context -> Input -> IO Bool
pointerCursorWanted Context
ctx Input
inp = Context -> Input -> UiCursorKind -> IO Bool
cursorKindIs Context
ctx Input
inp UiCursorKind
UiCursorPointer

cursorKindIs :: Context -> Input -> UiCursorKind -> IO Bool
cursorKindIs :: Context -> Input -> UiCursorKind -> IO Bool
cursorKindIs Context
ctx Input
inp UiCursorKind
want = (UiCursorKind -> UiCursorKind -> Bool
forall a. Eq a => a -> a -> Bool
== UiCursorKind
want) (UiCursorKind -> Bool) -> IO UiCursorKind -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Input -> IO UiCursorKind
uiCursorKind Context
ctx Input
inp