{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Widget node construction and interaction responses.
module NanoUI.Widgets.Node
  ( Response (..)
  , HasResponse (..)
  , respId
  , respRect
  , respHovered
  , respPressed
  , respClicked
  , respChanged
  , respSubmitted
  , respRightPressed
  , respRightClicked
  , mkResponse
  , emptyModalResp
  , setClicked
  , setChanged
  , setSubmitted
  , parentIdx
  , container
  , containerResponse
  , withContainerNode
  , floatingPanel
  , addWidget
  , addWidgetStyled
  , addWidgetWithOptions
  , addSizingLeafNode
  , resolveInteraction
  , tagContainer
  )
where

import Control.Monad (when)
import Data.IORef (readIORef, writeIORef)
import Data.Text (Text)
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , isDisabled
  , pointerBlockedByOverlay
  , OverlayState (..)
  , getsOverlay
  , modifyOverlay
  )
import NanoUI.Id (WidgetId (..), enterScope, hashWidgetId, scopeTag)
import NanoUI.Input
  ( Input (..)
  , inputMouseDown
  , inputMousePos
  , inputMouseReleased
  , inputMouseRightDown
  , inputMouseRightReleased
  )
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (..)
  , addNode
  , addNodeFromLayout
  , rootAttachParent
  , setNodeText
  , setOptions
  , setNodeValue
  , setStyleIdx
  , setWidgetId
  )
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)
import NanoUI.WidgetText (packTextNodeStyleFull)
import NanoUI.Style
  ( AlignX (..)
  , AlignY (..)
  , Direction (..)
  , Layout (..)
  , Padding (..)
  , Sizing (..)
  )
import NanoUI.Types (Rect (..), rectContains, rectH, rectHit, rectUnion, rectW)
import NanoUI.Frame.Hit (findNodeByWidgetId, nodeInteractionHit, scrollHitRect)

parentIdx :: [Int] -> Int
parentIdx :: [Int] -> Int
parentIdx = \case
  [] -> -Int
1
  (Int
p : [Int]
_) -> Int
p

-- | Anything that carries a widget 'Response' (composite widget results such
-- as 'NanoUI.Widgets.Tabs.TabResponse'). The @resp*@ accessors work on all of them.
class HasResponse r where
  toResponse :: r -> Response

instance HasResponse Response where
  {-# INLINE toResponse #-}
  toResponse :: Response -> Response
toResponse = Response -> Response
forall a. a -> a
id

{-# INLINE respId #-}
respId :: HasResponse r => r -> WidgetId
respId :: forall r. HasResponse r => r -> WidgetId
respId = Response -> WidgetId
rawRespId (Response -> WidgetId) -> (r -> Response) -> r -> WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respRect #-}
respRect :: HasResponse r => r -> Rect
respRect :: forall r. HasResponse r => r -> Rect
respRect = Response -> Rect
rawRespRect (Response -> Rect) -> (r -> Response) -> r -> Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respHovered #-}
respHovered :: HasResponse r => r -> Bool
respHovered :: forall r. HasResponse r => r -> Bool
respHovered = Response -> Bool
rawRespHovered (Response -> Bool) -> (r -> Response) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respPressed #-}
respPressed :: HasResponse r => r -> Bool
respPressed :: forall r. HasResponse r => r -> Bool
respPressed = Response -> Bool
rawRespPressed (Response -> Bool) -> (r -> Response) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respClicked #-}
respClicked :: HasResponse r => r -> Bool
respClicked :: forall r. HasResponse r => r -> Bool
respClicked = Response -> Bool
rawRespClicked (Response -> Bool) -> (r -> Response) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respChanged #-}
respChanged :: HasResponse r => r -> Bool
respChanged :: forall r. HasResponse r => r -> Bool
respChanged = Response -> Bool
rawRespChanged (Response -> Bool) -> (r -> Response) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respSubmitted #-}
respSubmitted :: HasResponse r => r -> Bool
respSubmitted :: forall r. HasResponse r => r -> Bool
respSubmitted = Response -> Bool
rawRespSubmitted (Response -> Bool) -> (r -> Response) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respRightPressed #-}
respRightPressed :: HasResponse r => r -> Bool
respRightPressed :: forall r. HasResponse r => r -> Bool
respRightPressed = Response -> Bool
rawRespRightPressed (Response -> Bool) -> (r -> Response) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

{-# INLINE respRightClicked #-}
respRightClicked :: HasResponse r => r -> Bool
respRightClicked :: forall r. HasResponse r => r -> Bool
respRightClicked = Response -> Bool
rawRespRightClicked (Response -> Bool) -> (r -> Response) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall r. HasResponse r => r -> Response
toResponse

data Response = Response
  { Response -> WidgetId
rawRespId :: !WidgetId
  , Response -> Rect
rawRespRect :: !Rect
  , Response -> Bool
rawRespHovered :: !Bool
  , Response -> Bool
rawRespPressed :: !Bool
  , Response -> Bool
rawRespClicked :: !Bool
  , Response -> Bool
rawRespChanged :: !Bool
  , Response -> Bool
rawRespSubmitted :: !Bool
  , Response -> Bool
rawRespRightPressed :: !Bool
  , Response -> Bool
rawRespRightClicked :: !Bool
  }
  deriving (Response -> Response -> Bool
(Response -> Response -> Bool)
-> (Response -> Response -> Bool) -> Eq Response
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
/= :: Response -> Response -> Bool
Eq, Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Response -> ShowS
showsPrec :: Int -> Response -> ShowS
$cshow :: Response -> String
show :: Response -> String
$cshowList :: [Response] -> ShowS
showList :: [Response] -> ShowS
Show)

instance Semigroup Response where
  Response
a <> :: Response -> Response -> Response
<> Response
b =
    Response
      { rawRespId :: WidgetId
rawRespId = if Response -> WidgetId
rawRespId Response
b WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> WidgetId
WidgetId Word64
0 then Response -> WidgetId
rawRespId Response
a else Response -> WidgetId
rawRespId Response
b
      , rawRespRect :: Rect
rawRespRect = Rect -> Rect -> Rect
unionRespRect (Response -> Rect
rawRespRect Response
a) (Response -> Rect
rawRespRect Response
b)
      , rawRespHovered :: Bool
rawRespHovered = Response -> Bool
rawRespHovered Response
a Bool -> Bool -> Bool
|| Response -> Bool
rawRespHovered Response
b
      , rawRespPressed :: Bool
rawRespPressed = Response -> Bool
rawRespPressed Response
a Bool -> Bool -> Bool
|| Response -> Bool
rawRespPressed Response
b
      , rawRespClicked :: Bool
rawRespClicked = Response -> Bool
rawRespClicked Response
a Bool -> Bool -> Bool
|| Response -> Bool
rawRespClicked Response
b
      , rawRespChanged :: Bool
rawRespChanged = Response -> Bool
rawRespChanged Response
a Bool -> Bool -> Bool
|| Response -> Bool
rawRespChanged Response
b
      , rawRespSubmitted :: Bool
rawRespSubmitted = Response -> Bool
rawRespSubmitted Response
a Bool -> Bool -> Bool
|| Response -> Bool
rawRespSubmitted Response
b
      , rawRespRightPressed :: Bool
rawRespRightPressed = Response -> Bool
rawRespRightPressed Response
a Bool -> Bool -> Bool
|| Response -> Bool
rawRespRightPressed Response
b
      , rawRespRightClicked :: Bool
rawRespRightClicked = Response -> Bool
rawRespRightClicked Response
a Bool -> Bool -> Bool
|| Response -> Bool
rawRespRightClicked Response
b
      }

instance Monoid Response where
  mempty :: Response
mempty = WidgetId -> Rect -> Bool -> Bool -> Bool -> Bool -> Response
mkResponse (Word64 -> WidgetId
WidgetId Word64
0) (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0) Bool
False Bool
False Bool
False Bool
False

unionRespRect :: Rect -> Rect -> Rect
unionRespRect :: Rect -> Rect -> Rect
unionRespRect Rect
a Rect
b
  | Rect -> Float
rectW Rect
a Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Rect -> Float
rectH Rect
a Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Rect
b
  | Rect -> Float
rectW Rect
b Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Rect -> Float
rectH Rect
b Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Rect
a
  | Bool
otherwise = Rect -> Rect -> Rect
rectUnion Rect
a Rect
b

setClicked :: Bool -> Response -> Response
setClicked :: Bool -> Response -> Response
setClicked Bool
c Response
r = Response
r {rawRespClicked = c}

setChanged :: Bool -> Response -> Response
setChanged :: Bool -> Response -> Response
setChanged Bool
c Response
r = Response
r {rawRespChanged = c}

setSubmitted :: Bool -> Response -> Response
setSubmitted :: Bool -> Response -> Response
setSubmitted Bool
s Response
r = Response
r {rawRespSubmitted = s}

mkResponse :: WidgetId -> Rect -> Bool -> Bool -> Bool -> Bool -> Response
mkResponse :: WidgetId -> Rect -> Bool -> Bool -> Bool -> Bool -> Response
mkResponse WidgetId
wid Rect
rect Bool
hovered Bool
pressed Bool
clicked Bool
changed =
  Response
    { rawRespId :: WidgetId
rawRespId = WidgetId
wid
    , rawRespRect :: Rect
rawRespRect = Rect
rect
    , rawRespHovered :: Bool
rawRespHovered = Bool
hovered
    , rawRespPressed :: Bool
rawRespPressed = Bool
pressed
    , rawRespClicked :: Bool
rawRespClicked = Bool
clicked
    , rawRespChanged :: Bool
rawRespChanged = Bool
changed
    , rawRespSubmitted :: Bool
rawRespSubmitted = Bool
False
    , rawRespRightPressed :: Bool
rawRespRightPressed = Bool
False
    , rawRespRightClicked :: Bool
rawRespRightClicked = Bool
False
    }

emptyModalResp :: WidgetId -> Response
emptyModalResp :: WidgetId -> Response
emptyModalResp WidgetId
wid = Response
forall a. Monoid a => a
mempty {rawRespId = wid}

container :: Ui :> es => NodeType -> Layout -> Eff es a -> Eff es a
container :: forall (es :: [Effect]) a.
(Ui :> es) =>
NodeType -> Layout -> Eff es a -> Eff es a
container NodeType
nt Layout
layout Eff es a
child = NodeType -> Layout -> Maybe WidgetId -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
NodeType -> Layout -> Maybe WidgetId -> Eff es a -> Eff es a
runContainer NodeType
nt Layout
layout Maybe WidgetId
forall a. Maybe a
Nothing Eff es a
child

containerResponse :: Ui :> es => NodeType -> Layout -> Eff es a -> Eff es (a, Response)
containerResponse :: forall (es :: [Effect]) a.
(Ui :> es) =>
NodeType -> Layout -> Eff es a -> Eff es (a, Response)
containerResponse NodeType
nt Layout
layout Eff es a
child = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  inp <- askInput
  r <- runContainer nt layout (Just wid) child
  resp <- uiIO (resolveInteraction ctx inp wid)
  pure (r, resp)

runContainer :: Ui :> es => NodeType -> Layout -> Maybe WidgetId -> Eff es a -> Eff es a
runContainer :: forall (es :: [Effect]) a.
(Ui :> es) =>
NodeType -> Layout -> Maybe WidgetId -> Eff es a -> Eff es a
runContainer NodeType
nt Layout
layout Maybe WidgetId
mWid Eff es a
child = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  idx <- uiIO $ do
    stack <- readIORef (ctxContainerStack ctx)
    idx <- addNodeFromLayout (ctxNodeArena ctx) nt (parentIdx stack) layout
    mapM_ (setWidgetId (ctxNodeArena ctx) idx) mWid
    pure idx
  withContainerNode True idx child

-- | Push container node @idx@ (already added under the current parent), run
-- @child@ inside it, then pop. @scoped@ also runs the children in a fresh id
-- scope; it changes the children's widget ids (and so their store keys), so
-- callers pick it explicitly: plain containers scope, scroll containers do not.
withContainerNode :: Ui :> es => Bool -> NodeIdx -> Eff es a -> Eff es a
withContainerNode :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool -> Int -> Eff es a -> Eff es a
withContainerNode Bool
scoped Int
idx Eff es a
child = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  (stack, parentIds) <- uiIO $ do
    stack0 <- readIORef (ctxContainerStack ctx)
    writeIORef (ctxContainerStack ctx) (idx : stack0)
    ids0 <- readIORef (ctxIdContext ctx)
    if scoped
      then do
        let (parentIds, childIds) = enterScope scopeTag ids0
        writeIORef (ctxIdContext ctx) childIds
        pure (stack0, parentIds)
      else pure (stack0, ids0)
  r <- child
  uiIO $ do
    writeIORef (ctxContainerStack ctx) stack
    when scoped $ writeIORef (ctxIdContext ctx) parentIds
  pure r

-- | A floating panel (popup, modal, window): its node attaches to the root
-- layer and it is the current floating panel while @body@ runs. @addPanel@
-- adds the node under the given parent; @enter@ runs once the node is pushed
-- (seeding its rect, opening a modal).
floatingPanel ::
  Ui :> es => Bool -> WidgetId -> (Int -> IO NodeIdx) -> IO () -> Eff es a -> Eff es a
floatingPanel :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool
-> WidgetId -> (Int -> IO Int) -> IO () -> Eff es a -> Eff es a
floatingPanel Bool
scoped WidgetId
wid Int -> IO Int
addPanel IO ()
enter Eff es a
body = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  let arena = Context -> NodeArena
ctxNodeArena Context
ctx
  prevFloat <- uiIO (getsOverlay ctx osCurrentFloatingId)
  idx <- uiIO $ do
    stack <- readIORef (ctxContainerStack ctx)
    idx <- addPanel =<< rootAttachParent arena (parentIdx stack)
    setWidgetId arena idx wid
    pure idx
  r <- withContainerNode scoped idx (uiIO (enter >> modifyOverlay ctx (\OverlayState
os -> OverlayState
os {osCurrentFloatingId = Just wid})) >> body)
  uiIO (modifyOverlay ctx (\OverlayState
os -> OverlayState
os {osCurrentFloatingId = prevFloat}))
  pure r

addSizingLeafNode ::
  Context
  -> Input
  -> WidgetId
  -> NodeType
  -> Direction
  -> Sizing
  -> Sizing
  -> IO Response
addSizingLeafNode :: Context
-> Input
-> WidgetId
-> NodeType
-> Direction
-> Sizing
-> Sizing
-> IO Response
addSizingLeafNode Context
ctx Input
inp WidgetId
wid NodeType
nt Direction
dir Sizing
wSiz Sizing
hSiz = do
  stack <- IORef [Int] -> IO [Int]
forall a. IORef a -> IO a
readIORef (Context -> IORef [Int]
ctxContainerStack Context
ctx)
  let
    parent = [Int] -> Int
parentIdx [Int]
stack
  idx <-
    addNode
      (ctxNodeArena ctx)
      nt
      parent
      dir
      wSiz
      hSiz
      (Padding 0 0 0 0)
      0
      0
      0
      1e9
      1e9
      0
      AlignStart
      AlignTop
  setWidgetId (ctxNodeArena ctx) idx wid
  resolveInteraction ctx inp wid

{-# INLINE addWidget #-}
addWidget ::
  Ui :> es =>
  WidgetId
  -> NodeType
  -> Text
  -> Float
  -> Layout
  -> Eff es Response
addWidget :: forall (es :: [Effect]).
(Ui :> es) =>
WidgetId -> NodeType -> Text -> Float -> Layout -> Eff es Response
addWidget WidgetId
wid NodeType
nt Text
txt Float
value Layout
layout = WidgetId
-> NodeType -> Text -> Float -> Layout -> Int -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
WidgetId
-> NodeType -> Text -> Float -> Layout -> Int -> Eff es Response
addWidgetStyled WidgetId
wid NodeType
nt Text
txt Float
value Layout
layout Int
0

{-# INLINE addWidgetStyled #-}
addWidgetStyled ::
  Ui :> es =>
  WidgetId
  -> NodeType
  -> Text
  -> Float
  -> Layout
  -> Int
  -> Eff es Response
addWidgetStyled :: forall (es :: [Effect]).
(Ui :> es) =>
WidgetId
-> NodeType -> Text -> Float -> Layout -> Int -> Eff es Response
addWidgetStyled WidgetId
wid NodeType
nt Text
txt Float
value Layout
layout Int
styleIdx = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  uiIO $ do
    stack <- readIORef (ctxContainerStack ctx)
    let
      parent = [Int] -> Int
parentIdx [Int]
stack
    idx <- addNodeFromLayout (ctxNodeArena ctx) nt parent layout
    setNodeText (ctxNodeArena ctx) idx txt
    setNodeValue (ctxNodeArena ctx) idx value
    let effectiveStyle
          | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeText = FontVariant
-> FontWeight -> FontStyle -> TextDecoration -> Int -> Int
packTextNodeStyleFull (Layout -> FontVariant
layoutFontVariant Layout
layout) (Layout -> FontWeight
layoutFontWeight Layout
layout) (Layout -> FontStyle
layoutFontStyle Layout
layout) (Layout -> TextDecoration
layoutTextDecoration Layout
layout) Int
styleIdx
          | Bool
otherwise = Int
styleIdx
    setStyleIdx (ctxNodeArena ctx) idx effectiveStyle
    setWidgetId (ctxNodeArena ctx) idx wid
    resolveInteraction ctx inp wid

addWidgetWithOptions ::
  Ui :> es =>
  WidgetId
  -> NodeType
  -> Text
  -> [Text]
  -> Float
  -> Layout
  -> Eff es Response
addWidgetWithOptions :: forall (es :: [Effect]).
(Ui :> es) =>
WidgetId
-> NodeType -> Text -> [Text] -> Float -> Layout -> Eff es Response
addWidgetWithOptions WidgetId
wid NodeType
nt Text
txt [Text]
opts Float
value Layout
layout = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  uiIO $ do
    stack <- readIORef (ctxContainerStack ctx)
    let parent = [Int] -> Int
parentIdx [Int]
stack
    idx <- addNodeFromLayout (ctxNodeArena ctx) nt parent layout
    setNodeText (ctxNodeArena ctx) idx txt
    setOptions (ctxNodeArena ctx) idx opts
    setNodeValue (ctxNodeArena ctx) idx value
    setStyleIdx (ctxNodeArena ctx) idx 0
    setWidgetId (ctxNodeArena ctx) idx wid
    resolveInteraction ctx inp wid

resolveInteraction :: Context -> Input -> WidgetId -> IO Response
resolveInteraction :: Context -> Input -> WidgetId -> IO Response
resolveInteraction Context
ctx Input
inp WidgetId
wid = do
  mrect <- Context -> WidgetId -> IO (Maybe Rect)
scrollHitRect Context
ctx WidgetId
wid
  active <- readIORef (ctxActiveId ctx)
  pending <- readIORef (ctxClickedId ctx)
  let
    mouse = Input -> V2
inputMousePos Input
inp
    rect = case Maybe Rect
mrect of
      Just Rect
r -> Rect
r
      Maybe Rect
Nothing -> Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0
    canHit = Rect -> V2 -> Bool
rectHit Rect
rect V2
mouse Bool -> Bool -> Bool
|| WidgetId
pending WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
  if not canHit
    then pure $! mkResponse wid rect False False False False
    else do
      disabled <- isDisabled ctx wid
      blocked <- pointerBlockedByOverlay ctx mouse
      mIdx <- findNodeByWidgetId ctx wid
      let
        hitAt V2
p = case Maybe Int
mIdx of
          Maybe Int
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect -> V2 -> Bool
rectContains Rect
rect V2
p)
          Just Int
idx -> Context -> Int -> Rect -> V2 -> IO Bool
nodeInteractionHit Context
ctx Int
idx Rect
rect V2
p
        -- Whether the button held in @ref@ went down on this widget. A press
        -- the frame never saw (synthesized input, or one swallowed before it
        -- arrived) leaves the gesture unowned, so nobody is ruled out.
        startedHere IORef (Maybe V2)
ref = IORef (Maybe V2) -> IO (Maybe V2)
forall a. IORef a -> IO a
readIORef IORef (Maybe V2)
ref IO (Maybe V2) -> (Maybe V2 -> 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
>>= IO Bool -> (V2 -> IO Bool) -> Maybe V2 -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) V2 -> IO Bool
hitAt
      -- A held button belongs to whatever it went down on. Another widget the
      -- drag passes over is not hovered, so it neither lights up nor reports a
      -- press of its own.
      captured <-
        if not (inputMouseDown inp)
          then pure False
          else
            if hashWidgetId active /= 0 && active /= wid
              then pure True
              else not <$> startedHere (ctxPressPos ctx)
      hovered <-
        if disabled || blocked || captured
          then pure False
          else hitAt mouse
      let
        pressed = Bool
hovered Bool -> Bool -> Bool
&& Input -> Bool
inputMouseDown Input
inp
        rightPressed = Bool
hovered Bool -> Bool -> Bool
&& Input -> Bool
inputMouseRightDown Input
inp
      -- The click belongs to whatever the press went down on: a release that
      -- drifted here from a neighbouring widget is not this widget's click.
      released <-
        if hovered && inputMouseReleased inp
          then startedHere (ctxPressPos ctx)
          else pure False
      rightReleased <-
        if hovered && inputMouseRightReleased inp
          then startedHere (ctxRightPressPos ctx)
          else pure False
      when (released && wid == active) $
        writeIORef (ctxReleaseClickedId ctx) wid
      let
        clicked = Bool
released Bool -> Bool -> Bool
|| WidgetId
pending WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
        rightClicked = Bool
rightReleased
      pure $!
        Response
          { rawRespId = wid
          , rawRespRect = rect
          , rawRespHovered = hovered
          , rawRespPressed = pressed
          , rawRespClicked = clicked
          , rawRespChanged = False
          , rawRespSubmitted = False
          , rawRespRightPressed = rightPressed
          , rawRespRightClicked = rightClicked
          }

-- | Stamp the current container with a widget id (radio/tree group key).
tagContainer :: Ui :> es => WidgetId -> Eff es ()
tagContainer :: forall (es :: [Effect]). (Ui :> es) => WidgetId -> Eff es ()
tagContainer WidgetId
wid = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO $ do
    stack <- readIORef (ctxContainerStack ctx)
    case stack of
      (Int
idx : [Int]
_) -> NodeArena -> Int -> WidgetId -> IO ()
setWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx WidgetId
wid
      [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()