{-# LANGUAGE DataKinds #-}

module NanoUI.Frame.Input
  ( finalizeTabFocus
  , refreshHover
  , armPointerPress
  , disarmPointerPress
  , finalizePointerPress
  , finalizePointerRelease
  , finalizeTextInputFocus
  , finalizeSelectFocus
  , findTopWidgetUnderMouse
  , isInteractiveNode
  ) where

import Control.Applicative ((<|>))
import Control.Monad (unless, when)
import Data.IORef (readIORef, writeIORef)
import qualified Data.IntMap.Strict as IM
import Data.Maybe (isJust, isNothing)
import NanoUI.Context
  ( Context (..)
  , TextInputMenu (..)
  , WidgetStore (..)
  , damageWidget
  , getFocusables
  , getMenuPointerGesture
  , getStore
  , getTextInputMenu
  , intKey
  , isDisabled
  , markDirty
  , pointerBlockedByOverlay
  , setAnimationValue
  , setMenuPointerGesture
  , setStore
  , setTextInputMenu
  , startAnimation
  )
import NanoUI.Frame.Focus (filterModalFocusables, tabNext, tabNextFocusables)
import NanoUI.Frame.Hit
  ( findNodeByWidgetId
  , modalTreeOpen
  , nodeClippedHit
  , nodeInteractionHit
  , overlayHitAllowed
  , scrollHitRect
  )
import NanoUI.Frame.Redraw (probeHotId)
import NanoUI.Frame.Select (findSelectUnderMouse, overlayMenuOwnerAt)
import NanoUI.Frame.Spans (widgetHitRect)
import NanoUI.Frame.TextEdit (collapseTextFieldSelection)
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input
  ( Input (..)
  , Key (..)
  , inputKeysElem
  , inputModifiers
  , inputMousePos
  , inputMousePressed
  , inputMouseReleased
  , inputMouseRightPressed
  , inputMouseRightReleased
  , modShift
  )
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (..)
  , findNodeM
  , foldNodesM
  , getNodeType
  , getParent
  , getRect
  , getStyleIdx
  , getWidgetId
  )
import NanoUI.Monad (whenM)
import NanoUI.Types (DamageBounds (..), Rect (..), V2 (..), defaultDamageSlop, rectContains, rectH, rectW)
import NanoUI.WidgetText (buttonVisualStyle, isMenuBarStyle, isMenuItemStyle, isTabButtonStyle)

finalizeTabFocus :: Context -> Input -> IO ()
finalizeTabFocus :: Context -> Input -> IO ()
finalizeTabFocus Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Key -> SmallArray Key -> Bool
inputKeysElem Key
KeyTab (Input -> SmallArray Key
inputKeys Input
inp)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    open <- Context -> IO Bool
modalTreeOpen Context
ctx
    let shift = Modifiers -> Bool
modShift (Input -> Modifiers
inputModifiers Input
inp)
    cur <- readIORef (ctxFocusId ctx)
    next <-
      if not open
        then tabNextFocusables ctx cur shift
        else do
          focusables <- getFocusables ctx
          ids <- filterModalFocusables ctx (filter (/= WidgetId 0) focusables)
          pure (tabNext cur ids shift)
    when (hashWidgetId next /= 0) $ do
      -- Keyboard focus shows its ring until the next pointer press. Focus that
      -- stays put (a lone focusable) changes no focus rect, so damage it here.
      wasVisible <- readIORef (ctxFocusVisible ctx)
      when (next == cur && not wasVisible) $
        damageWidget ctx next (DamageInflated defaultDamageSlop)
      writeIORef (ctxFocusId ctx) next
      writeIORef (ctxFocusVisible ctx) True
      markDirty ctx

-- Flat menu buttons never animate: their hover highlight snaps on and off.
isMenuButtonWidget :: Context -> WidgetId -> IO Bool
isMenuButtonWidget :: Context -> WidgetId -> IO Bool
isMenuButtonWidget Context
ctx WidgetId
wid
  | WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  | Bool
otherwise =
      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
          nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
          if nt /= NodeButton
            then pure False
            else do
              si <- getStyleIdx (ctxNodeArena ctx) idx
              pure (isMenuItemStyle si || isMenuBarStyle si)

refreshHover :: Context -> Input -> IO ()
refreshHover :: Context -> Input -> IO ()
refreshHover Context
ctx Input
inp = do
  prevHot <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxLastHotId Context
ctx)
  newHot <- probeHotId ctx (inputMousePos inp)
  writeIORef (ctxHotId ctx) newHot
  writeIORef (ctxLastHotId ctx) newHot
  when (prevHot /= newHot) $ do
    prevMenu <- isMenuButtonWidget ctx prevHot
    newMenu <- isMenuButtonWidget ctx newHot
    when (hashWidgetId prevHot /= 0 && not prevMenu) $ startAnimation ctx prevHot 1 0 0.12
    when (hashWidgetId newHot /= 0 && not newMenu) $ startAnimation ctx newHot 0 1 0.12

-- | Remember where a press landed, before the UI builds: widgets resolve their
-- click against this point, so a release that drifted onto a neighbour fires
-- nowhere. Runs every frame; 'disarmPointerPress' clears it once the button
-- comes up and the frame has consumed the release.
armPointerPress :: Context -> Input -> IO ()
armPointerPress :: Context -> Input -> IO ()
armPointerPress Context
ctx Input
inp = do
  let here :: Maybe V2
here = V2 -> Maybe V2
forall a. a -> Maybe a
Just (Input -> V2
inputMousePos Input
inp)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMousePressed Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe V2) -> Maybe V2 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe V2)
ctxPressPos Context
ctx) Maybe V2
here
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMouseRightPressed Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe V2) -> Maybe V2 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe V2)
ctxRightPressPos Context
ctx) Maybe V2
here

disarmPointerPress :: Context -> Input -> IO ()
disarmPointerPress :: Context -> Input -> IO ()
disarmPointerPress Context
ctx Input
inp = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMouseReleased Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe V2) -> Maybe V2 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe V2)
ctxPressPos Context
ctx) Maybe V2
forall a. Maybe a
Nothing
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMouseRightReleased Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe V2) -> Maybe V2 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe V2)
ctxRightPressPos Context
ctx) Maybe V2
forall a. Maybe a
Nothing

-- Same walk as refreshHover: later nodes paint first, earlier widget hits win.
finalizePointerPress :: Context -> Input -> IO ()
finalizePointerPress :: Context -> Input -> IO ()
finalizePointerPress Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMousePressed Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- A pointer press hides the keyboard focus ring.
    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef Bool
ctxFocusVisible Context
ctx) Bool
False
    gesture <- Context -> IO Bool
getMenuPointerGesture Context
ctx
    if gesture
      then writeIORef (ctxActiveId ctx) (WidgetId 0)
      else do
        let mouse = Input -> V2
inputMousePos Input
inp
        mMenu <- overlayMenuOwnerAt ctx mouse
        case mMenu of
          Just WidgetId
_ -> do
            Context -> Bool -> IO ()
setMenuPointerGesture Context
ctx Bool
True
            IORef WidgetId -> WidgetId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetId
ctxActiveId Context
ctx) (Word64 -> WidgetId
WidgetId Word64
0)
          Maybe WidgetId
Nothing -> do
            mWid <- Context -> V2 -> (NodeType -> Bool) -> IO (Maybe WidgetId)
findTopWidgetUnderMouse Context
ctx V2
mouse NodeType -> Bool
isInteractiveNode
            case mWid of
              Maybe WidgetId
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just WidgetId
wid ->
                IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> WidgetId -> IO Bool
isDisabled Context
ctx WidgetId
wid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  IORef WidgetId -> WidgetId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetId
ctxActiveId Context
ctx) WidgetId
wid

-- | The widget of a wanted type under @mouse@ that hover would pick: the
-- first in arena order, since earlier siblings paint over later ones.
findTopWidgetUnderMouse :: Context -> V2 -> (NodeType -> Bool) -> IO (Maybe WidgetId)
findTopWidgetUnderMouse :: Context -> V2 -> (NodeType -> Bool) -> IO (Maybe WidgetId)
findTopWidgetUnderMouse Context
ctx V2
mouse NodeType -> Bool
wanted = do
  let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  mIdx <-
    NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findNodeM NodeArena
na ((NodeIdx -> IO Bool) -> IO (Maybe NodeIdx))
-> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
forall a b. (a -> b) -> a -> b
$ \NodeIdx
idx -> do
      nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
      if not (wanted nt)
        then pure False
        else do
          (x, y, w, h) <- getRect na idx
          rect <- widgetHitRect ctx nt idx x y w h
          if rectW rect > 0 && rectH rect > 0
            then do
              hit <- nodeClippedHit ctx idx rect mouse
              if hit then overlayHitAllowed ctx idx mouse else pure False
            else pure False
  traverse (getWidgetId na) mIdx

isInteractiveNode :: NodeType -> Bool
isInteractiveNode :: NodeType -> Bool
isInteractiveNode NodeType
nt =
  NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeButton
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeCheckbox
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeRadio
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTree
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeSlider
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeSelect
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeColorPicker
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTextInput
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTextArea
    Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeDrawing

-- Clicks are finalized against solved layout rects; widgets only track press state.
-- Radio/tab selection is written here. Clickable widgets use the same solved
-- hit; if in-UI prev-rect tests missed, ctxClickedId fires next frame.
finalizePointerRelease :: Context -> Input -> IO ()
finalizePointerRelease :: Context -> Input -> IO ()
finalizePointerRelease Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMouseReleased Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let mouse :: V2
mouse = Input -> V2
inputMousePos Input
inp
        na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    gesture <- Context -> IO Bool
getMenuPointerGesture Context
ctx
    mMenu <- overlayMenuOwnerAt ctx mouse
    if gesture || isJust mMenu
      then do
        writeIORef (ctxActiveId ctx) (WidgetId 0)
        setMenuPointerGesture ctx False
      else do
        active <- readIORef (ctxActiveId ctx)
        when (hashWidgetId active /= 0) $ do
          releasedClicked <- readIORef (ctxReleaseClickedId ctx)
          -- Every node carrying the active id takes the release; the first
          -- one decides whether the pointer came up over the widget.
          let release Maybe Bool
over NodeIdx
idx = do
                wid <- NodeArena -> NodeIdx -> IO WidgetId
getWidgetId NodeArena
na NodeIdx
idx
                if wid /= active
                  then pure over
                  else do
                    nt <- getNodeType na idx
                    (x, y, w, h) <- getRect na idx
                    visible <- nodeClippedHit ctx idx (Rect x y w h) mouse
                    when visible $ do
                      case nt of
                        NodeType
NodeRadio -> NodeArena -> NodeIdx -> IO NodeIdx
getStyleIdx NodeArena
na NodeIdx
idx IO NodeIdx -> (NodeIdx -> 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
>>= Context -> NodeIdx -> NodeIdx -> IO ()
setParentSelection Context
ctx NodeIdx
idx
                        NodeType
NodeButton -> do
                          packed <- NodeArena -> NodeIdx -> IO NodeIdx
getStyleIdx NodeArena
na NodeIdx
idx
                          when (isTabButtonStyle packed) $
                            setParentSelection ctx idx (buttonVisualStyle packed `div` 4)
                        NodeType
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      when (postsLayoutClick nt && releasedClicked /= active) $ do
                        uiHit <- inUiClickHit ctx active mouse
                        unless uiHit $ writeIORef (ctxClickedId ctx) active
                    pure (over <|> Just visible)
          releasedOver <- foldNodesM na release Nothing
          writeIORef (ctxActiveId ctx) (WidgetId 0)
          when (releasedOver == Just True) $
            setAnimationValue ctx active 1

-- Radio options and tab buttons keep their selection on the parent group.
setParentSelection :: Context -> NodeIdx -> Int -> IO ()
setParentSelection :: Context -> NodeIdx -> NodeIdx -> IO ()
setParentSelection Context
ctx NodeIdx
idx NodeIdx
selected = do
  parent <- NodeArena -> NodeIdx -> IO NodeIdx
getParent (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
  when (parent >= 0) $ do
    store <- getStore ctx
    groupWid <- getWidgetId (ctxNodeArena ctx) parent
    setStore ctx store {storeInt = IM.insert (intKey groupWid) selected (storeInt store)}

postsLayoutClick :: NodeType -> Bool
postsLayoutClick :: NodeType -> Bool
postsLayoutClick NodeType
nt =
  NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeButton Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTree Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeSelect Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeCheckbox

inUiClickHit :: Context -> WidgetId -> V2 -> IO Bool
inUiClickHit :: Context -> WidgetId -> V2 -> IO Bool
inUiClickHit Context
ctx WidgetId
wid V2
mouse = do
  disabled <- Context -> WidgetId -> IO Bool
isDisabled Context
ctx WidgetId
wid
  blocked <- pointerBlockedByOverlay ctx mouse
  if disabled || blocked
    then pure False
    else do
      mrect <- scrollHitRect ctx wid
      case mrect of
        Maybe Rect
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Just Rect
r ->
          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 (Rect -> V2 -> Bool
rectContains Rect
r V2
mouse)
            Just NodeIdx
idx -> Context -> NodeIdx -> Rect -> V2 -> IO Bool
nodeInteractionHit Context
ctx NodeIdx
idx Rect
r V2
mouse

-- Focus text inputs using solved layout rects so the caret appears on first press.
-- A press on an open dropdown overlay (select menu or a focused combo's
-- suggestions) must not clear focus first: the combo's dropdown is visible
-- exactly while its field holds focus, and the select finalizers below need
-- the owner still resolvable to route the pick.
finalizeTextInputFocus :: Context -> Input -> IO ()
finalizeTextInputFocus :: Context -> Input -> IO ()
finalizeTextInputFocus Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMousePressed Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    mMenu <- Context -> IO (Maybe TextInputMenu)
getTextInputMenu Context
ctx
    let mouse = Input -> V2
inputMousePos Input
inp
    mDrop <- overlayMenuOwnerAt ctx mouse
    let onMenu = Bool -> (TextInputMenu -> Bool) -> Maybe TextInputMenu -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\TextInputMenu
menu -> Rect -> V2 -> Bool
rectContains (TextInputMenu -> Rect
textInputMenuRect TextInputMenu
menu) V2
mouse) Maybe TextInputMenu
mMenu
    when (not onMenu && isNothing mDrop) $ do
      prevFocus <- readIORef (ctxFocusId ctx)
      mFocused <- findTextInputUnderMouse ctx mouse
      case mFocused of
        Maybe WidgetId
Nothing -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WidgetId
prevFocus WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64 -> WidgetId
WidgetId Word64
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO ()
markDirty Context
ctx
          Context -> WidgetId -> IO ()
collapseTextFieldSelection Context
ctx WidgetId
prevFocus
          IORef WidgetId -> WidgetId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx) (Word64 -> WidgetId
WidgetId Word64
0)
          Context -> Maybe TextInputMenu -> IO ()
setTextInputMenu Context
ctx Maybe TextInputMenu
forall a. Maybe a
Nothing
        Just WidgetId
wid -> do
          IORef WidgetId -> WidgetId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx) WidgetId
wid
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WidgetId
prevFocus WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
/= WidgetId
wid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO ()
markDirty Context
ctx

finalizeSelectFocus :: Context -> Input -> IO ()
finalizeSelectFocus :: Context -> Input -> IO ()
finalizeSelectFocus Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMousePressed Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let mouse :: V2
mouse = Input -> V2
inputMousePos Input
inp
    mOpen <- Context -> V2 -> IO (Maybe WidgetId)
findSelectUnderMouse Context
ctx V2
mouse
    -- A press on a select's own field that just closed its dropdown leaves no
    -- open dropdown under the pointer, but the select keeps focus all the same.
    mWid <- maybe (findTopWidgetUnderMouse ctx mouse (== NodeSelect)) (pure . Just) mOpen
    case mWid of
      Maybe WidgetId
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just WidgetId
wid ->
        IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> WidgetId -> IO Bool
isDisabled Context
ctx WidgetId
wid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          prev <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx)
          writeIORef (ctxFocusId ctx) wid
          when (prev /= wid) $ markDirty ctx

findTextInputUnderMouse :: Context -> V2 -> IO (Maybe WidgetId)
findTextInputUnderMouse :: Context -> V2 -> IO (Maybe WidgetId)
findTextInputUnderMouse Context
ctx V2
mouse = do
  let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  mIdx <-
    NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findNodeM NodeArena
na ((NodeIdx -> IO Bool) -> IO (Maybe NodeIdx))
-> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
forall a b. (a -> b) -> a -> b
$ \NodeIdx
idx -> do
      nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
      if nt /= NodeTextInput && nt /= NodeTextArea
        then pure False
        else do
          (x, y, w, h) <- getRect na idx
          rect <- widgetHitRect ctx nt idx x y w h
          hit <- nodeClippedHit ctx idx rect mouse
          if hit then overlayHitAllowed ctx idx mouse else pure False
  mWid <- traverse (getWidgetId na) mIdx
  -- A press on a disabled field lands on nothing: it takes focus from
  -- whichever field had it and gives it to none.
  case mWid of
    Just WidgetId
wid -> do
      disabled <- Context -> WidgetId -> IO Bool
isDisabled Context
ctx WidgetId
wid
      pure (if disabled then Nothing else Just wid)
    Maybe WidgetId
Nothing -> Maybe WidgetId -> IO (Maybe WidgetId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe WidgetId
forall a. Maybe a
Nothing