{-# LANGUAGE DataKinds #-}

-- | Scroll input: offsets baked into the arena, wheel routing, and scrollbar
-- thumb drags and track jumps.
module NanoUI.Frame.Scroll
  ( applyScrollOffsets
  , updateScrollWheel
  , updateScrollDrag
  , scrollBarsFor
  , scrollBarLayout
  , ScrollBarLayout (..)
  ) where

import Control.Applicative ((<|>))
import Control.Monad (forM_, void, when)
import Data.Foldable (find)
import Data.Maybe (fromMaybe)
import NanoUI.Context
  ( Context (..)
  , ScrollAxes (..)
  , ScrollBehavior (..)
  , applyScrollTarget
  , beginScrollMetrics
  , cacheScrollMetrics
  , clampScrollOffset
  , getMenuPointerGesture
  , getScrollDrag
  , getScrollOffset
  , getScrollOffset2D
  , getScrollOffsetIn
  , resolveScrollStep
  , scrollTargetOffset
  , setScrollOffset
  , setScrollOffset2D
  , nodeTheme
  , InteractionState (..)
  , getsInteraction
  , modifyInteraction
  )
import NanoUI.Frame.Hit (topmostModalAtMouse, topmostOverlayAtMouse)
import NanoUI.Frame.Node (ScrollNode (..), readScrollNode, scrollNodeViewport)
import NanoUI.Frame.Scroll.Geometry
  ( ScrollBarLayout (..)
  , ScrollConfig
  , borderContentClip
  , decodeScrollConfig
  , isScrollStyle2D
  , scrollAxisRange
  , scrollBarLayout
  , scrollBarLayouts2D
  , scrollChromeLane
  , scrollChromeSuppressed
  , scrollOffsetFromThumb
  , scrollWheelSuppressed
  )
import NanoUI.Frame.TextArea.Content (textAreaContentGeom)
import NanoUI.Frame.TextArea.Geometry (TextAreaBars (..), TextAreaScrollBarLayouts (..), textAreaBars, textAreaScrollBarLayouts)
import NanoUI.Id (WidgetId)
import NanoUI.Input (Input (..), inputMouseDown, inputMousePos, inputMousePressed, inputMouseReleased, inputScroll)
import NanoUI.Layout.Arena
  ( DirTag (..)
  , NodeIdx
  , NodeType (..)
  , arenaCount
  , findNodeM
  , forChildNodes_
  , getDirection
  , getFirstChild
  , getLayoutRect
  , getNextSibling
  , getNodeType
  , getParent
  , getRect
  , getStyleIdx
  , getWidgetId
  , isFloatingNode
  , isScrollNode
  , setClipRect
  , setRect
  , snapshotLayoutRects
  )
import NanoUI.Style (Padding (..), themePanel)
import NanoUI.Types (Rect (..), V2 (..), rectContains, rectIntersect, rectUnion)

applyScrollOffsets :: Context -> IO ()
applyScrollOffsets :: Context -> IO ()
applyScrollOffsets Context
ctx = do
  Context -> IO ()
beginScrollMetrics Context
ctx
  NodeArena -> IO ()
snapshotLayoutRects (Context -> NodeArena
ctxNodeArena Context
ctx)
  -- A frame that added no widgets has no root to walk.
  count <- NodeArena -> IO NodeIdx
arenaCount (Context -> NodeArena
ctxNodeArena Context
ctx)
  when (count > 0) $ do
    (wx, wy, ww, wh) <- getRect (ctxNodeArena ctx) 0
    transformSubtree ctx 0 0 0 (Rect wx wy ww wh)

transformSubtree :: Context -> NodeIdx -> Float -> Float -> Rect -> IO ()
transformSubtree :: Context -> NodeIdx -> Float -> Float -> Rect -> IO ()
transformSubtree Context
ctx NodeIdx
idx Float
scrollX Float
scrollY Rect
parentClip = do
  let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
  (lx, ly, lw, lh) <- getLayoutRect na idx
  let floating = NodeType -> Bool
isFloatingNode NodeType
nt
      (sx, sy) = if floating then (0, 0) else (scrollX, scrollY)
      within Rect
r = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
parentClip (Rect -> Rect -> Maybe Rect
rectIntersect Rect
parentClip Rect
r)
  (vx, vy, vw, vh) <-
    if floating
      then getRect na idx
      else pure (lx + sx, ly + sy, lw, lh)
  when (not floating) $ setRect na idx vx vy vw vh
  (!childScrollX, !childScrollY, !childClip) <-
    if isScrollNode nt
      then do
        (axes, viewport, range) <- scrollNodeGeometry ctx idx (Rect vx vy lw lh)
        wid <- getWidgetId na idx
        -- The only pass that sees a scroller's placed geometry. Everything
        -- that scrolls one between frames reads it back from here.
        cacheScrollMetrics ctx wid axes viewport range
        V2 dx dy <- getScrollOffsetIn ctx wid axes
        let clip = Rect -> Rect
within Rect
viewport
        setClipRect na idx clip
        pure (sx - dx, sy - dy, clip)
      else do
        clip <-
          case nt of
            NodeType
NodePanel -> do
              theme <- Context -> NodeIdx -> IO Theme
nodeTheme Context
ctx NodeIdx
idx
              pure (within (borderContentClip (themePanel theme) (Rect vx vy vw vh)))
            NodeType
_ -> Rect -> IO Rect
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect -> IO Rect) -> Rect -> IO Rect
forall a b. (a -> b) -> a -> b
$! if Bool
floating then Float -> Float -> Float -> Float -> Rect
Rect Float
vx Float
vy Float
vw Float
vh else Rect
parentClip
        setClipRect na idx clip
        pure (sx, sy, clip)
  forChildNodes_ na idx $ \NodeIdx
ci ->
    Context -> NodeIdx -> Float -> Float -> Rect -> IO ()
transformSubtree Context
ctx NodeIdx
ci Float
childScrollX Float
childScrollY Rect
childClip

-- | Axes, content viewport and reachable offset range of the scroll container
-- at @idx@ placed at @rect@, in window axes. The wheel, the programmatic
-- commands and the transform pass all size a scroll off this, so a scroller
-- cannot disagree with itself about how far it reaches.
scrollNodeGeometry :: Context -> NodeIdx -> Rect -> IO (ScrollAxes, Rect, V2)
scrollNodeGeometry :: Context -> NodeIdx -> Rect -> IO (ScrollAxes, Rect, V2)
scrollNodeGeometry Context
ctx NodeIdx
idx (Rect Float
x Float
y Float
w Float
h) = do
  sn@ScrollNode {snPad = pad, snContentMain = contentMain} <- NodeArena -> NodeIdx -> IO ScrollNode
readScrollNode (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
  let viewport = ScrollNode -> Float -> Float -> Float -> Float -> Rect
scrollNodeViewport ScrollNode
sn Float
x Float
y Float
w Float
h
      rangeH = Float -> Float -> Float -> Float
scrollAxisRange Float
contentMain (Rect -> Float
rectH Rect
viewport) (Padding -> Float
padB Padding
pad)
  pure $
    if sn2D sn
      then (ScrollAxisXY, viewport, V2 (scrollAxisRange (snContentW sn) (rectW viewport) (padR pad)) rangeH)
      else case snDir sn of
        DirTag
DirColumn -> (ScrollAxes
ScrollAxisY, Rect
viewport, Float -> Float -> V2
V2 Float
0 Float
rangeH)
        DirTag
DirRow -> (ScrollAxes
ScrollAxisX, Rect
viewport, Float -> Float -> V2
V2 (Float -> Float -> Float -> Float
scrollAxisRange Float
contentMain (Rect -> Float
rectW Rect
viewport) (Padding -> Float
padR Padding
pad)) Float
0)

updateScrollWheel :: Context -> Input -> IO ()
updateScrollWheel :: Context -> Input -> IO ()
updateScrollWheel Context
ctx Input
inp = do
  let scroll :: V2
scroll@(V2 Float
wheelX Float
wheelY) = Input -> V2
inputScroll Input
inp
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
wheelY Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
0 Bool -> Bool -> Bool
|| Float
wheelX Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- An open dropdown (select menu or combo suggestions) owns the wheel:
    -- the combo widget scrolls its own window, and the scroller underneath
    -- the floating list must not move with it.
    mDrop <- Context
-> (InteractionState -> Maybe (WidgetId, Rect))
-> IO (Maybe (WidgetId, Rect))
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe (WidgetId, Rect)
isOpenSelectDrop
    let overDrop = Bool
-> ((WidgetId, Rect) -> Bool) -> Maybe (WidgetId, Rect) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\(WidgetId
_, Rect
r) -> Rect -> V2 -> Bool
rectContains Rect
r (Input -> V2
inputMousePos Input
inp)) Maybe (WidgetId, Rect)
mDrop
    when (not overDrop) $ do
      mNode <- findScrollNodeUnderMouse ctx (inputMousePos inp)
      forM_ mNode $ \NodeIdx
idx -> do
        wid <- NodeArena -> NodeIdx -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
        void (tryApplyScrollWheelDelta ctx wid scroll)
        applyCrossAxisScroll ctx idx scroll

-- Nested 2D: apply the unused axis to a paired scroller in the same panel.
-- Do not walk past panel/window/modal into the page scroller.
applyCrossAxisScroll :: Context -> NodeIdx -> V2 -> IO ()
applyCrossAxisScroll :: Context -> NodeIdx -> V2 -> IO ()
applyCrossAxisScroll Context
ctx NodeIdx
idx V2
scroll = do
  dir <- NodeArena -> NodeIdx -> IO DirTag
getDirection (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
  mAnc <- walkOppositeAncestor ctx idx dir
  case mAnc of
    Just WidgetId
pwid -> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Context -> WidgetId -> V2 -> IO Bool
tryApplyScrollWheelDelta Context
ctx WidgetId
pwid V2
scroll)
    Maybe WidgetId
Nothing -> do
      mDesc <- Context -> NodeIdx -> DirTag -> IO (Maybe WidgetId)
findOppositeScrollDescendant Context
ctx NodeIdx
idx DirTag
dir
      forM_ mDesc $ \WidgetId
dwid -> Context -> WidgetId -> V2 -> IO Bool
tryApplyScrollWheelDelta Context
ctx WidgetId
dwid V2
scroll

scrollCrossAxisStop :: NodeType -> Bool
scrollCrossAxisStop :: NodeType -> Bool
scrollCrossAxisStop NodeType
nt =
  NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodePanel Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeWindow Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeModal

walkOppositeAncestor :: Context -> NodeIdx -> DirTag -> IO (Maybe WidgetId)
walkOppositeAncestor :: Context -> NodeIdx -> DirTag -> IO (Maybe WidgetId)
walkOppositeAncestor Context
ctx NodeIdx
idx DirTag
childDir = do
  p <- NodeArena -> NodeIdx -> IO NodeIdx
getParent (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
  if p < 0
    then pure Nothing
    else do
      nt <- getNodeType (ctxNodeArena ctx) p
      if scrollCrossAxisStop nt
        then pure Nothing
        else
          if not (isScrollNode nt)
            then walkOppositeAncestor ctx p childDir
            else do
              pdir <- getDirection (ctxNodeArena ctx) p
              if pdir == childDir
                then walkOppositeAncestor ctx p childDir
                else Just <$> getWidgetId (ctxNodeArena ctx) p

findOppositeScrollDescendant :: Context -> NodeIdx -> DirTag -> IO (Maybe WidgetId)
findOppositeScrollDescendant :: Context -> NodeIdx -> DirTag -> IO (Maybe WidgetId)
findOppositeScrollDescendant Context
ctx NodeIdx
idx DirTag
childDir = NodeIdx -> IO (Maybe WidgetId)
goChildren NodeIdx
idx
  where
    want :: DirTag
want = if DirTag
childDir DirTag -> DirTag -> Bool
forall a. Eq a => a -> a -> Bool
== DirTag
DirColumn then DirTag
DirRow else DirTag
DirColumn
    goChildren :: NodeIdx -> IO (Maybe WidgetId)
goChildren NodeIdx
parent = NodeArena -> NodeIdx -> IO NodeIdx
getFirstChild (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
parent IO NodeIdx
-> (NodeIdx -> IO (Maybe WidgetId)) -> IO (Maybe WidgetId)
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 (Maybe WidgetId)
go
    go :: NodeIdx -> IO (Maybe WidgetId)
go NodeIdx
ci
      | NodeIdx
ci NodeIdx -> NodeIdx -> Bool
forall a. Ord a => a -> a -> Bool
< NodeIdx
0 = 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
      | Bool
otherwise = do
          nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
ci
          found <-
            if isScrollNode nt
              then do
                d <- getDirection (ctxNodeArena ctx) ci
                if d == want
                  then Just <$> getWidgetId (ctxNodeArena ctx) ci
                  else goChildren ci
              else goChildren ci
          case found of
            Just WidgetId
w -> Maybe WidgetId -> IO (Maybe WidgetId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WidgetId -> Maybe WidgetId
forall a. a -> Maybe a
Just WidgetId
w)
            Maybe WidgetId
Nothing -> NodeArena -> NodeIdx -> IO NodeIdx
getNextSibling (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
ci IO NodeIdx
-> (NodeIdx -> IO (Maybe WidgetId)) -> IO (Maybe WidgetId)
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 (Maybe WidgetId)
go

-- | Node owning scroller @wid@: its text area, or the first scroll container
-- with that id that the predicate does not rule out (table slave panes share
-- an id with their master). Thumb drags use the chrome predicate, since a
-- hidden bar has no lane to grab; the wheel uses the wider one, since a
-- hidden bar still scrolls.
scrollOwnerNode :: (ScrollConfig -> Bool -> DirTag -> Bool) -> Context -> WidgetId -> IO (Maybe NodeIdx)
scrollOwnerNode :: (ScrollConfig -> Bool -> DirTag -> Bool)
-> Context -> WidgetId -> IO (Maybe NodeIdx)
scrollOwnerNode ScrollConfig -> Bool -> DirTag -> Bool
suppressed Context
ctx WidgetId
wid =
  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 /= NodeTextArea && not (isScrollNode nt)
      then pure False
      else do
        owner <- getWidgetId na idx
        if owner /= wid
          then pure False
          else
            if nt == NodeTextArea
              then pure True
              else do
                si <- getStyleIdx na idx
                dir <- getDirection na idx
                pure (not (suppressed (decodeScrollConfig si) (isScrollStyle2D si) dir))
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx

tryApplyScrollWheelDelta :: Context -> WidgetId -> V2 -> IO Bool
tryApplyScrollWheelDelta :: Context -> WidgetId -> V2 -> IO Bool
tryApplyScrollWheelDelta Context
ctx WidgetId
wid (V2 Float
wheelX Float
wheelY) = do
  mIdx <- (ScrollConfig -> Bool -> DirTag -> Bool)
-> Context -> WidgetId -> IO (Maybe NodeIdx)
scrollOwnerNode ScrollConfig -> Bool -> DirTag -> Bool
scrollWheelSuppressed 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 -> do
      nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
      (axes, range) <-
        if nt == NodeTextArea
          then do
            (fm, field, contentW, contentH) <- textAreaContentGeom ctx idx
            let bars = FontMetrics -> Rect -> Float -> Float -> TextAreaBars
textAreaBars FontMetrics
fm Rect
field Float
contentW Float
contentH
            pure
              ( ScrollAxisXY
              , V2 (max 0 (contentW - tabViewW bars)) (max 0 (contentH - tabViewH bars))
              )
          else do
            (x, y, w, h) <- getRect na idx
            (axes, _, range) <- scrollNodeGeometry ctx idx (Rect x y w h)
            pure (axes, range)
      step <- resolveScrollStep ctx wid
      cur <- getScrollOffsetIn ctx wid axes
      -- Notches land on where the scroller is headed, not on where it is, so
      -- a flick mid-glide adds to the throw instead of restarting it.
      base@(V2 baseX baseY) <- scrollTargetOffset ctx wid cur
      let next = V2 -> V2 -> V2
clampScrollOffset V2
range (Float -> Float -> V2
V2 (Float
baseX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
wheelX Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
step) (Float
baseY Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
wheelY Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
step))
      if next == base && next == cur
        then pure False
        else True <$ applyScrollTarget ctx wid axes next ScrollSmooth
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx

findScrollNodeUnderMouse :: Context -> V2 -> IO (Maybe NodeIdx)
findScrollNodeUnderMouse :: Context -> V2 -> IO (Maybe NodeIdx)
findScrollNodeUnderMouse Context
ctx V2
mouse = do
  count <- NodeArena -> IO NodeIdx
arenaCount (Context -> NodeArena
ctxNodeArena Context
ctx)
  if count <= 0
    then pure Nothing
    else do
      mModal <- topmostModalAtMouse ctx mouse
      mTop <- topmostOverlayAtMouse ctx mouse
      let start = NodeIdx -> Maybe NodeIdx -> NodeIdx
forall a. a -> Maybe a -> a
fromMaybe NodeIdx
0 (Maybe NodeIdx
mModal Maybe NodeIdx -> Maybe NodeIdx -> Maybe NodeIdx
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe NodeIdx
mTop)
      (x, y, w, h) <- getRect (ctxNodeArena ctx) start
      queryScrollTarget ctx start mouse (Rect x y w h)

queryScrollTarget :: Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)
queryScrollTarget :: Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)
queryScrollTarget Context
ctx NodeIdx
idx V2
mouse Rect
parentClip = do
  nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
  mClipHere <- scrollHitClip ctx idx nt parentClip
  case mClipHere of
    Maybe Rect
Nothing -> Maybe NodeIdx -> IO (Maybe NodeIdx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NodeIdx
forall a. Maybe a
Nothing
    Just Rect
clip -> do
      childHit <- Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)
walkScrollSiblings Context
ctx NodeIdx
idx V2
mouse Rect
clip
      case childHit of
        Just NodeIdx
hit -> Maybe NodeIdx -> IO (Maybe NodeIdx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeIdx -> Maybe NodeIdx
forall a. a -> Maybe a
Just NodeIdx
hit)
        Maybe NodeIdx
Nothing -> Context -> NodeIdx -> NodeType -> V2 -> Rect -> IO (Maybe NodeIdx)
scrollHitSelf Context
ctx NodeIdx
idx NodeType
nt V2
mouse Rect
clip

walkScrollSiblings :: Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)
walkScrollSiblings :: Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)
walkScrollSiblings Context
ctx NodeIdx
parent V2
mouse Rect
clip = NodeArena -> NodeIdx -> IO NodeIdx
getFirstChild (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
parent IO NodeIdx -> (NodeIdx -> IO (Maybe NodeIdx)) -> IO (Maybe NodeIdx)
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 (Maybe NodeIdx)
go
  where
    go :: NodeIdx -> IO (Maybe NodeIdx)
go NodeIdx
ci
      | NodeIdx
ci NodeIdx -> NodeIdx -> Bool
forall a. Ord a => a -> a -> Bool
< NodeIdx
0 = Maybe NodeIdx -> IO (Maybe NodeIdx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NodeIdx
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          hit <- Context -> NodeIdx -> V2 -> Rect -> IO (Maybe NodeIdx)
queryScrollTarget Context
ctx NodeIdx
ci V2
mouse Rect
clip
          case hit of
            Just NodeIdx
found -> Maybe NodeIdx -> IO (Maybe NodeIdx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeIdx -> Maybe NodeIdx
forall a. a -> Maybe a
Just NodeIdx
found)
            Maybe NodeIdx
Nothing -> NodeArena -> NodeIdx -> IO NodeIdx
getNextSibling (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
ci IO NodeIdx -> (NodeIdx -> IO (Maybe NodeIdx)) -> IO (Maybe NodeIdx)
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 (Maybe NodeIdx)
go

scrollHitSelf :: Context -> NodeIdx -> NodeType -> V2 -> Rect -> IO (Maybe NodeIdx)
scrollHitSelf :: Context -> NodeIdx -> NodeType -> V2 -> Rect -> IO (Maybe NodeIdx)
scrollHitSelf Context
ctx NodeIdx
idx NodeType
nt V2
mouse Rect
clip
  | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeTextArea = do
      (fm, field, contentW, contentH) <- Context -> NodeIdx -> IO (FontMetrics, Rect, Float, Float)
textAreaContentGeom Context
ctx NodeIdx
idx
      let bars = FontMetrics -> Rect -> Float -> Float -> TextAreaBars
textAreaBars FontMetrics
fm Rect
field Float
contentW Float
contentH
      pure $ case rectIntersect clip field of
        Just Rect
fclip
          | Rect -> Bool
visibleHit Rect
fclip Bool -> Bool -> Bool
&& (TextAreaBars -> Bool
tabVertical TextAreaBars
bars Bool -> Bool -> Bool
|| TextAreaBars -> Bool
tabHorizontal TextAreaBars
bars) -> NodeIdx -> Maybe NodeIdx
forall a. a -> Maybe a
Just NodeIdx
idx
        Maybe Rect
_ -> Maybe NodeIdx
forall a. Maybe a
Nothing
  | NodeType -> Bool
isScrollNode NodeType
nt Bool -> Bool -> Bool
&& Rect -> Bool
visibleHit Rect
clip = Maybe NodeIdx -> IO (Maybe NodeIdx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeIdx -> Maybe NodeIdx
forall a. a -> Maybe a
Just NodeIdx
idx)
  | Bool
otherwise = Maybe NodeIdx -> IO (Maybe NodeIdx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NodeIdx
forall a. Maybe a
Nothing
  where
    visibleHit :: Rect -> Bool
visibleHit r :: Rect
r@(Rect Float
_ Float
_ Float
rw Float
rh) = Float
rw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Float
rh Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Rect -> V2 -> Bool
rectContains Rect
r V2
mouse

-- Same clip stack as the span walk: scroll viewport (plus its bar lanes),
-- then panel bounds.
scrollHitClip :: Context -> NodeIdx -> NodeType -> Rect -> IO (Maybe Rect)
scrollHitClip :: Context -> NodeIdx -> NodeType -> Rect -> IO (Maybe Rect)
scrollHitClip Context
ctx NodeIdx
idx NodeType
nt Rect
parentClip
  | NodeType -> Bool
isScrollNode NodeType
nt = do
      (x, y, w, h) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect NodeArena
na NodeIdx
idx
      sn <- readScrollNode na idx
      let lane DirTag
d = ScrollBarSlot
-> DirTag -> Float -> Float -> Float -> Float -> Padding -> Rect
scrollChromeLane (ScrollNode -> ScrollBarSlot
snSlot ScrollNode
sn) DirTag
d Float
x Float
y Float
w Float
h (ScrollNode -> Padding
snPad ScrollNode
sn)
          viewport = ScrollNode -> Float -> Float -> Float -> Float -> Rect
scrollNodeViewport ScrollNode
sn Float
x Float
y Float
w Float
h
          hit
            | ScrollNode -> Bool
sn2D ScrollNode
sn = Rect -> Rect -> Rect
rectUnion Rect
viewport (Rect -> Rect -> Rect
rectUnion (DirTag -> Rect
lane DirTag
DirColumn) (DirTag -> Rect
lane DirTag
DirRow))
            | Bool
otherwise = Rect -> Rect -> Rect
rectUnion Rect
viewport (DirTag -> Rect
lane (ScrollNode -> DirTag
snDir ScrollNode
sn))
      pure (rectIntersect parentClip hit)
  | NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodePanel = do
      (x, y, w, h) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect NodeArena
na NodeIdx
idx
      pure (rectIntersect parentClip (Rect x y w h))
  | Bool
otherwise = Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
parentClip)
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx

-- | Scrollbar layouts of the scroller at @idx@ (id @wid@), each paired with a
-- setter for that axis's offset that skips unchanged values. Covers text
-- areas and native 2D and 1D scroll containers; a 1D scroller with suppressed
-- chrome has none.
scrollBarsFor :: Context -> NodeIdx -> WidgetId -> IO [(DirTag, ScrollBarLayout, Float -> IO ())]
scrollBarsFor :: Context
-> NodeIdx
-> WidgetId
-> IO [(DirTag, ScrollBarLayout, Float -> IO ())]
scrollBarsFor Context
ctx NodeIdx
idx WidgetId
wid = do
  nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
  if nt == NodeTextArea
    then do
      (fm, field, contentW, contentH) <- textAreaContentGeom ctx idx
      cur@(V2 curX curY) <- getScrollOffset2D ctx wid
      let layouts = FontMetrics
-> Rect
-> Float
-> Float
-> Float
-> Float
-> TextAreaScrollBarLayouts
textAreaScrollBarLayouts FontMetrics
fm Rect
field Float
contentW Float
contentH Float
curX Float
curY
      pure (axes2D cur (tasbVertical layouts) (tasbHorizontal layouts))
    else do
      (x, y, w, h) <- getRect na idx
      ScrollNode slot cfg native2D dir pad contentMain contentW <- readScrollNode na idx
      if native2D
        then do
          cur@(V2 offX offY) <- getScrollOffset2D ctx wid
          let (mV, mH) = scrollBarLayouts2D slot cfg x y w h pad contentW contentMain offX offY
          pure (axes2D cur mV mH)
        else
          if scrollChromeSuppressed cfg dir
            then pure []
            else do
              off <- getScrollOffset ctx wid
              pure
                [ (dir, layout, \Float
new -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
new Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
off) (Context -> WidgetId -> Float -> IO ()
setScrollOffset Context
ctx WidgetId
wid Float
new))
                | Just layout <- [scrollBarLayout slot dir x y w h pad contentMain off]
                ]
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    axes2D :: V2
-> Maybe ScrollBarLayout
-> Maybe ScrollBarLayout
-> [(DirTag, ScrollBarLayout, Float -> IO ())]
axes2D (V2 Float
curX Float
curY) Maybe ScrollBarLayout
mV Maybe ScrollBarLayout
mH =
      [(DirTag
DirColumn, ScrollBarLayout
layout, \Float
new -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
new Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
curY) (Context -> WidgetId -> V2 -> IO ()
setScrollOffset2D Context
ctx WidgetId
wid (Float -> Float -> V2
V2 Float
curX Float
new))) | Just ScrollBarLayout
layout <- [Maybe ScrollBarLayout
mV]]
        [(DirTag, ScrollBarLayout, Float -> IO ())]
-> [(DirTag, ScrollBarLayout, Float -> IO ())]
-> [(DirTag, ScrollBarLayout, Float -> IO ())]
forall a. [a] -> [a] -> [a]
++ [(DirTag
DirRow, ScrollBarLayout
layout, \Float
new -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
new Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
curX) (Context -> WidgetId -> V2 -> IO ()
setScrollOffset2D Context
ctx WidgetId
wid (Float -> Float -> V2
V2 Float
new Float
curY))) | Just ScrollBarLayout
layout <- [Maybe ScrollBarLayout
mH]]

updateScrollDrag :: Context -> Input -> IO ()
updateScrollDrag :: Context -> Input -> IO ()
updateScrollDrag Context
ctx Input
inp
  | Input -> Bool
inputMouseReleased Input
inp = Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isScrollDrag = Nothing})
  | Bool
otherwise = do
      gesture <- Context -> IO Bool
getMenuPointerGesture Context
ctx
      mDrag <- getScrollDrag ctx
      case mDrag of
        Maybe (WidgetId, DirTag, Float)
_ | Bool
gesture -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (WidgetId
wid, DirTag
dragDir, Float
grabOff)
          | Input -> Bool
inputMouseDown Input
inp -> do
              -- A hidden bar has no lane to grab.
              bars <- IO [(DirTag, ScrollBarLayout, Float -> IO ())]
-> (NodeIdx -> IO [(DirTag, ScrollBarLayout, Float -> IO ())])
-> Maybe NodeIdx
-> IO [(DirTag, ScrollBarLayout, Float -> IO ())]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(DirTag, ScrollBarLayout, Float -> IO ())]
-> IO [(DirTag, ScrollBarLayout, Float -> IO ())]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (\NodeIdx
idx -> Context
-> NodeIdx
-> WidgetId
-> IO [(DirTag, ScrollBarLayout, Float -> IO ())]
scrollBarsFor Context
ctx NodeIdx
idx WidgetId
wid) (Maybe NodeIdx -> IO [(DirTag, ScrollBarLayout, Float -> IO ())])
-> IO (Maybe NodeIdx)
-> IO [(DirTag, ScrollBarLayout, Float -> IO ())]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ScrollConfig -> Bool -> DirTag -> Bool)
-> Context -> WidgetId -> IO (Maybe NodeIdx)
scrollOwnerNode (\ScrollConfig
cfg Bool
_ DirTag
dir -> ScrollConfig -> DirTag -> Bool
scrollChromeSuppressed ScrollConfig
cfg DirTag
dir) Context
ctx WidgetId
wid
              forM_ bars $ \(DirTag
dir, ScrollBarLayout
layout, Float -> IO ()
setOffset) ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DirTag
dir DirTag -> DirTag -> Bool
forall a. Eq a => a -> a -> Bool
== DirTag
dragDir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  Float -> IO ()
setOffset (DirTag -> ScrollBarLayout -> Float -> V2 -> Float
scrollOffsetFromThumb DirTag
dir ScrollBarLayout
layout Float
grabOff (Input -> V2
inputMousePos Input
inp))
        Maybe (WidgetId, DirTag, Float)
Nothing | Input -> Bool
inputMousePressed Input
inp -> Context -> Input -> IO ()
tryStartScrollDrag Context
ctx Input
inp
        Maybe (WidgetId, DirTag, Float)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Grab a thumb, or jump the thumb's center to a track press and keep
-- dragging from there.
tryStartScrollDrag :: Context -> Input -> IO ()
tryStartScrollDrag :: Context -> Input -> IO ()
tryStartScrollDrag Context
ctx Input
inp = do
  let mouse :: V2
mouse = Input -> V2
inputMousePos Input
inp
  mIdx <- Context -> V2 -> IO (Maybe NodeIdx)
findScrollNodeUnderMouse Context
ctx V2
mouse
  forM_ mIdx $ \NodeIdx
hitIdx -> do
    wid <- NodeArena -> NodeIdx -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
hitIdx
    bars <- maybe (pure []) (\NodeIdx
idx -> Context
-> NodeIdx
-> WidgetId
-> IO [(DirTag, ScrollBarLayout, Float -> IO ())]
scrollBarsFor Context
ctx NodeIdx
idx WidgetId
wid) =<< scrollOwnerNode (\ScrollConfig
cfg Bool
_ DirTag
dir -> ScrollConfig -> DirTag -> Bool
scrollChromeSuppressed ScrollConfig
cfg DirTag
dir) ctx wid
    forM_ (find (\(DirTag
_, ScrollBarLayout
l, Float -> IO ()
_) -> Rect -> V2 -> Bool
rectContains (ScrollBarLayout -> Rect
sbThumb ScrollBarLayout
l) V2
mouse Bool -> Bool -> Bool
|| Rect -> V2 -> Bool
rectContains (ScrollBarLayout -> Rect
sbTrack ScrollBarLayout
l) V2
mouse) bars) $
        \(DirTag
dir, ScrollBarLayout
layout, Float -> IO ()
setOffset) -> do
          let thumb :: Rect
thumb = ScrollBarLayout -> Rect
sbThumb ScrollBarLayout
layout
              along :: V2 -> Float
along (V2 Float
mx Float
my) = if DirTag
dir DirTag -> DirTag -> Bool
forall a. Eq a => a -> a -> Bool
== DirTag
DirColumn then Float
my else Float
mx
              Rect Float
tx Float
ty Float
tw Float
th = Rect
thumb
          if Rect -> V2 -> Bool
rectContains Rect
thumb V2
mouse
            then Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isScrollDrag = Just (wid, dir, along mouse - along (V2 tx ty))})
            else do
              let half :: Float
half = V2 -> Float
along (Float -> Float -> V2
V2 Float
tw Float
th) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
              Float -> IO ()
setOffset (DirTag -> ScrollBarLayout -> Float -> V2 -> Float
scrollOffsetFromThumb DirTag
dir ScrollBarLayout
layout Float
half V2
mouse)
              Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isScrollDrag = Just (wid, dir, half)})