{-# LANGUAGE DataKinds #-}

module NanoUI.Frame.Select
  ( selectDropRect
  , selectDropPickIndex
  , closeSelectOnOutsideClick
  , finalizeSelectKeyboard
  , finalizeSelectPick
  , markSelectDropPress
  , drawSelectOverlays
  , collectSelectDropdownSpans
  , findSelectUnderMouse
  , overlayMenuOwnerAt
  , cacheOpenSelectDrop
  , tagSelectClippedSpans
  , comboDropRect
  , comboDropPickIndex
  , comboScrollGeom
  ) where

import Control.Monad (forM, forM_, unless, when)
import Data.Foldable (find)
import Data.IORef (readIORef, writeIORef)
import qualified Data.IntMap.Strict as IM
import Data.Maybe (catMaybes, listToMaybe, maybeToList)
import qualified Data.Text as T
import NanoUI.Context
  ( Context (..)
  , TextInputMenu (..)
  , WidgetStore (..)
  , anySelectOpen
  , closeSelects
  , getStore
  , getTextInputMenu
  , intKey
  , isSelectOpen
  , markDirty
  , markEscapeConsumed
  , setSelectOpen
  , setStore
  , widgetTheme
  , isDisabled
  , InteractionState (..)
  , modifyInteraction
  )
import NanoUI.Draw (pushRect, pushRoundedRect, pushText, withClip)
import NanoUI.Font (FontMetrics, centeredTextY, menuItemPadX, menuItemRowH, menuOuterPad, widgetContentInset)
import NanoUI.Frame.Chrome (overlayMenuStyle, paintMenuAccent, paintMenuPanel)
import NanoUI.Frame.Hit (findNodeByWidgetId, widgetOverlayAllowed)
import NanoUI.Frame.Scroll.Geometry (padTextClipRect)
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input (Input (..), Key (..), foldInputKeys, inputKeys, inputMouseDown, inputMousePos, inputMousePressed)
import NanoUI.Layout.Arena (NodeType (NodeSelect, NodeTextInput), findNodeM, foldNodeRevM, getNodeType, lookupNodeByWidgetId, getOptions, getRect, getWidgetId)
import NanoUI.Store (Slot (..), slotKey)
import NanoUI.Style (Style (..), Theme (..), scrollBarThumbColor, scrollBarTrackColor, themeAccent, themeInput)
import NanoUI.Types (Color (..), Rect (..), V2 (..), rectContains, rectIntersect)
import NanoUI.WidgetText (selectChevronReserve)

-- | An open dropdown: a select with its open flag set, or a combo box (a
-- search field carrying options) exactly while it holds focus.
data Dropdown = Dropdown
  { Dropdown -> WidgetId
ddWidget :: !WidgetId
  , Dropdown -> Bool
ddCombo :: !Bool
  , Dropdown -> [Text]
ddOptions :: [T.Text]
  , Dropdown -> Rect
ddAnchor :: !Rect
  , Dropdown -> Rect
ddRect :: !Rect
  , Dropdown -> Int
ddPicked :: !Int
  -- ^ Row shown as picked: the select's value, or the combo's keyboard
  -- highlight relative to its window (-1 highlights nothing).
  , Dropdown -> Int
ddComboRows :: !Int
  , Dropdown -> Int
ddComboWindow :: !Int
  , Dropdown -> Float
ddComboScrollX :: !Float
  , Dropdown -> Float
ddComboContentW :: !Float
  }

-- | Every open dropdown, in arena order.
openDropdowns :: Context -> IO [Dropdown]
openDropdowns :: Context -> IO [Dropdown]
openDropdowns Context
ctx = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  focus <- readIORef (ctxFocusId ctx)
  -- Selects open only through the store flag and combos only while focused.
  -- With no select open, the focused node is the only candidate, so only an
  -- open select walks the arena.
  if anySelectOpen store
    then foldNodeRevM na (\[Dropdown]
acc Int
idx -> [Dropdown]
-> (Dropdown -> [Dropdown]) -> Maybe Dropdown -> [Dropdown]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Dropdown]
acc (Dropdown -> [Dropdown] -> [Dropdown]
forall a. a -> [a] -> [a]
: [Dropdown]
acc) (Maybe Dropdown -> [Dropdown])
-> IO (Maybe Dropdown) -> IO [Dropdown]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WidgetStore -> WidgetId -> Int -> IO (Maybe Dropdown)
dropdownAt WidgetStore
store WidgetId
focus Int
idx) []
    else
      if hashWidgetId focus == 0
        then pure []
        else maybe (pure []) (fmap maybeToList . dropdownAt store focus) =<< lookupNodeByWidgetId na focus
  where
    na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
    dropdownAt :: WidgetStore -> WidgetId -> Int -> IO (Maybe Dropdown)
dropdownAt WidgetStore
store WidgetId
focus Int
idx =
      NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx IO NodeType
-> (NodeType -> IO (Maybe Dropdown)) -> IO (Maybe Dropdown)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        NodeType
NodeSelect -> do
          wid <- NodeArena -> Int -> IO WidgetId
getWidgetId NodeArena
na Int
idx
          if isSelectOpen store (intKey wid) then Just <$> build store idx wid False else pure Nothing
        NodeType
NodeTextInput -> do
          wid <- NodeArena -> Int -> IO WidgetId
getWidgetId NodeArena
na Int
idx
          opts <- getOptions na idx
          if wid /= focus || null opts then pure Nothing else Just <$> build store idx wid True
        NodeType
_ -> Maybe Dropdown -> IO (Maybe Dropdown)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Dropdown
forall a. Maybe a
Nothing
    build :: WidgetStore -> Int -> WidgetId -> Bool -> IO Dropdown
build WidgetStore
store Int
idx WidgetId
wid Bool
combo = do
      opts <- NodeArena -> Int -> IO [Text]
getOptions NodeArena
na Int
idx
      (x, y, w, h) <- getRect na idx
      let key = WidgetId -> Int
intKey WidgetId
wid
          slotInt Slot
slot Int
def = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
def (Slot -> Int -> Int
slotKey Slot
slot Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
          slotFloat Slot
slot = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 (Slot -> Int -> Int
slotKey Slot
slot Int
key) (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
          nOpts = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
opts
          rows = Slot -> Int -> Int
slotInt Slot
SlotComboCount Int
nOpts
          window = Slot -> Int -> Int
slotInt Slot
SlotComboScroll Int
0
          contentW = Slot -> Float
slotFloat Slot
SlotComboContentW
      pure
        Dropdown
          { ddWidget = wid
          , ddCombo = combo
          , ddOptions = opts
          , ddAnchor = Rect x y w h
          , ddRect =
              if combo
                then comboDropRect x y w h nOpts rows contentW
                else selectDropRect x y w h nOpts
          , ddPicked =
              if combo
                then slotInt SlotComboHighlight (-1) - window
                else IM.findWithDefault 0 key (storeInt store)
          , ddComboRows = rows
          , ddComboWindow = window
          , ddComboScrollX = slotFloat SlotComboScrollX
          , ddComboContentW = contentW
          }

-- | One placed row of an open dropdown.
data DropdownRow = DropdownRow
  { DropdownRow -> Int
drIndex :: !Int
  , DropdownRow -> Text
drOption :: T.Text
  , DropdownRow -> Rect
drRect :: !Rect
  , DropdownRow -> Float
drTextX :: !Float
  , DropdownRow -> Bool
drHovered :: !Bool
  }

-- | Rows of an open dropdown, shared by its painter and its text spans. Combo
-- rows sit flush at the drop rect's top edge (no outer margin) and scroll
-- horizontally; select rows keep their padded layout.
dropdownRows :: FontMetrics -> V2 -> Dropdown -> [DropdownRow]
dropdownRows :: FontMetrics -> V2 -> Dropdown -> [DropdownRow]
dropdownRows FontMetrics
fm V2
mouse Dropdown
dd =
  let Rect Float
dx Float
dy Float
dw Float
_ = Dropdown -> Rect
ddRect Dropdown
dd
      top :: Float
top = if Dropdown -> Bool
ddCombo Dropdown
dd then Float
dy else Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
menuOuterPad
      textX0 :: Float
textX0 = Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
menuItemPadX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float, Float) -> Float
forall a b. (a, b) -> a
fst (FontMetrics -> (Float, Float)
widgetContentInset FontMetrics
fm)
      textX :: Float
textX = if Dropdown -> Bool
ddCombo Dropdown
dd then Float
textX0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Dropdown -> Float
ddComboScrollX Dropdown
dd else Float
textX0
   in [ Int -> Text -> Rect -> Float -> Bool -> DropdownRow
DropdownRow Int
i Text
opt Rect
row Float
textX (Rect -> V2 -> Bool
rectContains Rect
row V2
mouse)
      | (Int
i, Text
opt) <- [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Dropdown -> [Text]
ddOptions Dropdown
dd)
      , let row :: Rect
row = Float -> Float -> Float -> Float -> Rect
Rect Float
dx (Float
top Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
menuItemRowH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) Float
dw Float
menuItemRowH
      ]

overlayMenuOwnerAt :: Context -> V2 -> IO (Maybe WidgetId)
overlayMenuOwnerAt :: Context -> V2 -> IO (Maybe WidgetId)
overlayMenuOwnerAt Context
ctx V2
mouse = do
  mMenu <- Context -> IO (Maybe TextInputMenu)
getTextInputMenu Context
ctx
  case mMenu of
    Just TextInputMenu
m | Rect -> V2 -> Bool
rectContains (TextInputMenu -> Rect
textInputMenuRect TextInputMenu
m) V2
mouse -> 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 (TextInputMenu -> WidgetId
textInputMenuWidget TextInputMenu
m))
    Maybe TextInputMenu
_ -> (Dropdown -> WidgetId) -> Maybe Dropdown -> Maybe WidgetId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dropdown -> WidgetId
ddWidget (Maybe Dropdown -> Maybe WidgetId)
-> ([Dropdown] -> Maybe Dropdown) -> [Dropdown] -> Maybe WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dropdown -> Bool) -> [Dropdown] -> Maybe Dropdown
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Dropdown
dd -> Rect -> V2 -> Bool
rectContains (Dropdown -> Rect
ddRect Dropdown
dd) V2
mouse) ([Dropdown] -> Maybe WidgetId)
-> IO [Dropdown] -> IO (Maybe WidgetId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO [Dropdown]
openDropdowns Context
ctx

cacheOpenSelectDrop :: Context -> IO ()
cacheOpenSelectDrop :: Context -> IO ()
cacheOpenSelectDrop Context
ctx = do
  dropdowns <- Context -> IO [Dropdown]
openDropdowns Context
ctx
  modifyInteraction ctx (\InteractionState
s -> InteractionState
s {isOpenSelectDrop = (\Dropdown
dd -> (Dropdown -> WidgetId
ddWidget Dropdown
dd, Dropdown -> Rect
ddRect Dropdown
dd)) <$> listToMaybe dropdowns})

markSelectDropPress :: Context -> Input -> IO ()
markSelectDropPress :: Context -> Input -> IO ()
markSelectDropPress Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMouseDown Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    store <- Context -> IO WidgetStore
getStore Context
ctx
    when (anySelectOpen store) $ do
      let mouse = Input -> V2
inputMousePos Input
inp
      dropdowns <- openDropdowns ctx
      when (any (\Dropdown
dd -> Rect -> V2 -> Bool
rectContains (Dropdown -> Rect
ddAnchor Dropdown
dd) V2
mouse Bool -> Bool -> Bool
|| Rect -> V2 -> Bool
rectContains (Dropdown -> Rect
ddRect Dropdown
dd) V2
mouse) dropdowns) $
        modifyInteraction ctx (\InteractionState
s -> InteractionState
s {isSelectDropPress = True})

closeSelectOnOutsideClick :: Context -> Input -> IO ()
closeSelectOnOutsideClick :: Context -> Input -> IO ()
closeSelectOnOutsideClick Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMousePressed Input
inp Bool -> Bool -> Bool
|| Input -> Bool
inputMouseReleased Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    store <- Context -> IO WidgetStore
getStore Context
ctx
    when (anySelectOpen store) $ do
      let mouse = Input -> V2
inputMousePos Input
inp
      dropdowns <- openDropdowns ctx
      unless (any (\Dropdown
dd -> Rect -> V2 -> Bool
rectContains (Dropdown -> Rect
ddAnchor Dropdown
dd) V2
mouse Bool -> Bool -> Bool
|| Rect -> V2 -> Bool
rectContains (Dropdown -> Rect
ddRect Dropdown
dd) V2
mouse) dropdowns) $
        setStore ctx (closeSelects store)

finalizeSelectKeyboard :: Context -> Input -> IO ()
finalizeSelectKeyboard :: Context -> Input -> IO ()
finalizeSelectKeyboard Context
ctx Input
inp = do
  let (Bool
wantNext, Bool
wantPrev, Bool
wantEsc, Bool
wantEnter) =
        ((Bool, Bool, Bool, Bool) -> Key -> (Bool, Bool, Bool, Bool))
-> (Bool, Bool, Bool, Bool)
-> SmallArray Key
-> (Bool, Bool, Bool, Bool)
forall a. (a -> Key -> a) -> a -> SmallArray Key -> a
foldInputKeys
          ( \(Bool
n, Bool
p, Bool
e, Bool
r) Key
k ->
              ( Bool
n Bool -> Bool -> Bool
|| Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
KeyDown Bool -> Bool -> Bool
|| Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
KeyRight
              , Bool
p Bool -> Bool -> Bool
|| Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
KeyUp Bool -> Bool -> Bool
|| Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
KeyLeft
              , Bool
e Bool -> Bool -> Bool
|| Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
KeyEscape
              , Bool
r Bool -> Bool -> Bool
|| Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
KeyEnter
              )
          )
          (Bool
False, Bool
False, Bool
False, Bool
False)
          (Input -> SmallArray Key
inputKeys Input
inp)
      wantStep :: Bool
wantStep = Bool
wantNext Bool -> Bool -> Bool
|| Bool
wantPrev
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
wantStep Bool -> Bool -> Bool
|| Bool
wantEsc Bool -> Bool -> Bool
|| Bool
wantEnter) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    focus <- IORef WidgetId -> IO WidgetId
forall a. IORef a -> IO a
readIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx)
    store <- getStore ctx
    mTarget <- pickSelectKeyboardTarget ctx focus store wantStep
    forM_ mTarget $ \(WidgetId
wid, Bool
open) -> do
      allow <- Context -> WidgetId -> IO Bool
widgetOverlayAllowed Context
ctx WidgetId
wid
      when allow $
        if wantEsc || wantEnter
          then when open $ do
            setStore ctx (setSelectOpen store (intKey wid) False)
            when wantEsc $ markEscapeConsumed ctx
            markDirty ctx
          else do
            mIdx <- findNodeByWidgetId ctx wid
            forM_ mIdx $ \Int
idx -> do
              n <- [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> IO [Text] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeArena -> Int -> IO [Text]
getOptions (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
              when (n > 0) $ do
                let key = WidgetId -> Int
intKey WidgetId
wid
                    cur = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
key (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
                    next = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
cur Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Bool
wantNext then Int
1 else -Int
1))
                when (next /= cur) $ do
                  setStore ctx (store {storeInt = IM.insert key next (storeInt store)})
                  markDirty ctx

pickSelectKeyboardTarget :: Context -> WidgetId -> WidgetStore -> Bool -> IO (Maybe (WidgetId, Bool))
pickSelectKeyboardTarget :: Context
-> WidgetId -> WidgetStore -> Bool -> IO (Maybe (WidgetId, Bool))
pickSelectKeyboardTarget Context
ctx WidgetId
focus WidgetStore
store Bool
wantStep = do
  mFocus <- if Bool
wantStep then Context -> WidgetId -> IO (Maybe WidgetId)
selectWidgetIfAny Context
ctx WidgetId
focus else 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
  case mFocus of
    Just WidgetId
wid -> Maybe (WidgetId, Bool) -> IO (Maybe (WidgetId, Bool))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((WidgetId, Bool) -> Maybe (WidgetId, Bool)
forall a. a -> Maybe a
Just (WidgetId
wid, WidgetStore -> Int -> Bool
isSelectOpen WidgetStore
store (WidgetId -> Int
intKey WidgetId
wid)))
    Maybe WidgetId
Nothing -> (WidgetId -> (WidgetId, Bool))
-> Maybe WidgetId -> Maybe (WidgetId, Bool)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Bool
True) (Maybe WidgetId -> Maybe (WidgetId, Bool))
-> IO (Maybe WidgetId) -> IO (Maybe (WidgetId, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO (Maybe WidgetId)
findOpenSelectWidget Context
ctx

selectWidgetIfAny :: Context -> WidgetId -> IO (Maybe WidgetId)
selectWidgetIfAny :: Context -> WidgetId -> IO (Maybe WidgetId)
selectWidgetIfAny Context
ctx WidgetId
wid
  | WidgetId -> Word64
hashWidgetId WidgetId
wid Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
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
      mIdx <- Context -> WidgetId -> IO (Maybe Int)
findNodeByWidgetId Context
ctx WidgetId
wid
      case mIdx of
        Maybe Int
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
        Just Int
idx -> do
          nt <- NodeArena -> Int -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
          disabled <- isDisabled ctx wid
          pure (if nt == NodeSelect && not disabled then Just wid else Nothing)

findOpenSelectWidget :: Context -> IO (Maybe WidgetId)
findOpenSelectWidget :: Context -> IO (Maybe WidgetId)
findOpenSelectWidget Context
ctx = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let na = Context -> NodeArena
ctxNodeArena Context
ctx
  mIdx <-
    findNodeM na $ \Int
idx -> do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
idx
      if nt /= NodeSelect
        then pure False
        else isSelectOpen store . intKey <$> getWidgetId na idx
  traverse (getWidgetId na) mIdx

finalizeSelectPick :: Context -> Input -> IO ()
finalizeSelectPick :: Context -> Input -> IO ()
finalizeSelectPick Context
ctx Input
inp =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Input -> Bool
inputMousePressed Input
inp Bool -> Bool -> Bool
|| Input -> Bool
inputMouseReleased Input
inp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let mouse :: V2
mouse@(V2 Float
_ Float
mouseY) = Input -> V2
inputMousePos Input
inp
    dropdowns <- Context -> IO [Dropdown]
openDropdowns Context
ctx
    forM_ dropdowns $ \Dropdown
dd -> do
      allow <- Context -> WidgetId -> IO Bool
widgetOverlayAllowed Context
ctx (Dropdown -> WidgetId
ddWidget Dropdown
dd)
      when (allow && rectContains (ddRect dd) mouse) $ do
        st <- getStore ctx
        let wid = Dropdown -> WidgetId
ddWidget Dropdown
dd
            key = WidgetId -> Int
intKey WidgetId
wid
            nOpts = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dropdown -> [Text]
ddOptions Dropdown
dd)
        if ddCombo dd
          then do
            -- Combo: pick on press only, never from the scrollbar lanes, so
            -- finishing a thumb drag cannot commit a row. Picking commits the
            -- option text into the field and defocuses it: the combo's
            -- dropdown is visible exactly while focused, so the menu
            -- disappears with the pick.
            let (_, vSb, hSb, _) = comboScrollGeom (ddRect dd) (ddComboRows dd) nOpts (ddComboWindow dd) (ddComboScrollX dd) (ddComboContentW dd)
                onLane = ((Rect, Rect) -> Bool) -> [(Rect, Rect)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Rect
track, Rect
_) -> Rect -> V2 -> Bool
rectContains Rect
track V2
mouse) ([Maybe (Rect, Rect)] -> [(Rect, Rect)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Rect, Rect)
vSb, Maybe (Rect, Rect)
hSb])
            when (inputMousePressed inp && not onLane) $
              forM_ (comboDropPickIndex (ddRect dd) menuItemRowH nOpts mouseY) $ \Int
picked -> do
                let txt :: Text
txt = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Text -> Text
forall a. a -> a
id ([Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
picked (Dropdown -> [Text]
ddOptions Dropdown
dd)))
                    len :: Int
len = Text -> Int
T.length Text
txt
                Context -> WidgetStore -> IO ()
setStore
                  Context
ctx
                  ( WidgetStore
st
                      { storeText = IM.insert key txt (storeText st)
                      , storeInt =
                          IM.insert (slotKey SlotCursor key) len $
                            IM.insert (slotKey SlotAnchor key) len (storeInt st)
                      }
                  )
                IORef WidgetId -> WidgetId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx) (Word64 -> WidgetId
WidgetId Word64
0)
                Context -> IO ()
markDirty Context
ctx
          else
            forM_ (selectDropPickIndex (ddRect dd) menuItemRowH nOpts mouseY) $ \Int
picked -> do
              Context -> WidgetStore -> IO ()
setStore Context
ctx (WidgetStore -> Int -> Bool -> WidgetStore
setSelectOpen (WidgetStore
st {storeInt = IM.insert key picked (storeInt st)}) Int
key Bool
False)
              IORef WidgetId -> WidgetId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef WidgetId
ctxFocusId Context
ctx) WidgetId
wid
              Context -> IO ()
markDirty Context
ctx

-- | Topmost open dropdown owner (in reverse arena order) whose anchor or menu
-- is under @mouse@ and that the modal state lets receive input.
findSelectUnderMouse :: Context -> V2 -> IO (Maybe WidgetId)
findSelectUnderMouse :: Context -> V2 -> IO (Maybe WidgetId)
findSelectUnderMouse Context
ctx V2
mouse = do
  dropdowns <- Context -> IO [Dropdown]
openDropdowns Context
ctx
  firstAllowed [dd | dd <- reverse dropdowns, rectContains (ddAnchor dd) mouse || rectContains (ddRect dd) mouse]
  where
    firstAllowed :: [Dropdown] -> IO (Maybe WidgetId)
firstAllowed [] = 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
    firstAllowed (Dropdown
dd : [Dropdown]
rest) = do
      allow <- Context -> WidgetId -> IO Bool
widgetOverlayAllowed Context
ctx (Dropdown -> WidgetId
ddWidget Dropdown
dd)
      if allow then pure (Just (ddWidget dd)) else firstAllowed rest

-- | Vertical gap between the select widget and its dropdown menu.
selectDropGap :: Float
selectDropGap :: Float
selectDropGap = Float
4

selectDropRect :: Float -> Float -> Float -> Float -> Int -> Rect
selectDropRect :: Float -> Float -> Float -> Float -> Int -> Rect
selectDropRect Float
x Float
y Float
w Float
h Int
nOpts =
  Float -> Float -> Float -> Float -> Rect
Rect Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
selectDropGap) Float
w (Float
menuItemRowH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nOpts Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
menuOuterPad)

selectDropPickIndex :: Rect -> Float -> Int -> Float -> Maybe Int
selectDropPickIndex :: Rect -> Float -> Int -> Float -> Maybe Int
selectDropPickIndex Rect
dropRect Float
itemH Int
nOpts Float
mouseY =
  let Rect Float
_ Float
dy Float
_ Float
dh = Rect
dropRect
      innerH :: Float
innerH = Float
itemH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nOpts
      rel :: Float
rel = Float
mouseY Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 ((Float
dh Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
innerH) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
   in if Float
rel Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0 Bool -> Bool -> Bool
|| Float
rel Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
innerH
        then Maybe Int
forall a. Maybe a
Nothing
        else Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
nOpts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float
rel Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
itemH Float
1))))

-- Combo dropdown scrollbar sizes: lane thickness and the shortest a thumb
-- ever gets.
comboSbW, comboSbMinThumb :: Float
comboSbW :: Float
comboSbW = Float
10
comboSbMinThumb :: Float
comboSbMinThumb = Float
24

-- | Scrollbar geometry for a combo dropdown, shared by the overlay painter,
-- the pick guard, and the widget's thumb-drag gesture. The list has no outer
-- margin: rows fill the drop rect edge to edge, and a vertical lane sits on
-- the right when rows overflow the window, a horizontal one on the bottom
-- when the widest row overflows the width. Returns (inner rows area,
-- vertical (track, thumb), horizontal (track, thumb), usable content width).
comboScrollGeom ::
  Rect ->
  Int ->
  Int ->
  Int ->
  Float ->
  Float ->
  (Rect, Maybe (Rect, Rect), Maybe (Rect, Rect), Float)
comboScrollGeom :: Rect
-> Int
-> Int
-> Int
-> Float
-> Float
-> (Rect, Maybe (Rect, Rect), Maybe (Rect, Rect), Float)
comboScrollGeom (Rect Float
dx Float
dy Float
dw Float
dh) Int
n Int
vis Int
win Float
xOff Float
contentW =
  let
    vScroll :: Bool
vScroll = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
vis Bool -> Bool -> Bool
&& Int
vis Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    vLaneW :: Float
vLaneW = if Bool
vScroll then Float
comboSbW else Float
0
    usableW :: Float
usableW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
dw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vLaneW)
    hScroll :: Bool
hScroll = Float
contentW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
usableW Bool -> Bool -> Bool
&& Float
contentW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0
    hLaneH :: Float
hLaneH = if Bool
hScroll then Float
comboSbW else Float
0
    -- Rows fill the drop rect from the top, stopping short of the lanes.
    inner :: Rect
inner = Float -> Float -> Float -> Float -> Rect
Rect Float
dx Float
dy (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
dw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vLaneW)) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
dh Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hLaneH))
    -- Lanes sit flush against the dropdown border and share the corner.
    vTrack :: Rect
vTrack = Float -> Float -> Float -> Float -> Rect
Rect (Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
comboSbW) Float
dy Float
comboSbW (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
dh Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hLaneH))
    hTrack :: Rect
hTrack = Float -> Float -> Float -> Float -> Rect
Rect Float
dx (Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dh Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
comboSbW) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
dw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vLaneW)) Float
comboSbW
    vSb :: Maybe (Rect, Rect)
vSb =
      if Bool
vScroll
        then
          let Rect Float
vx Float
vy Float
_ Float
vh = Rect
vTrack
              trackH :: Float
trackH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 Float
vh
              thumbH :: Float
thumbH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
comboSbMinThumb Float
trackH) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
trackH (Float
trackH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
vis Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n))
              maxWin :: Int
maxWin = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
vis)
              ty :: Float
ty = Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
trackH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
thumbH) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxWin Int
win)) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxWin
           in (Rect, Rect) -> Maybe (Rect, Rect)
forall a. a -> Maybe a
Just (Rect
vTrack, Float -> Float -> Float -> Float -> Rect
Rect (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2) Float
ty (Float
comboSbW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
4) Float
thumbH)
        else Maybe (Rect, Rect)
forall a. Maybe a
Nothing
    hSb :: Maybe (Rect, Rect)
hSb =
      if Bool
hScroll
        then
          let Rect Float
hx Float
hy Float
hw Float
_ = Rect
hTrack
              trackW :: Float
trackW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 Float
hw
              thumbW :: Float
thumbW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
comboSbMinThumb Float
trackW) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
trackW (Float
trackW Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
usableW Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
contentW))
              maxOff :: Float
maxOff = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (Float
contentW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
usableW)
              tx :: Float
tx = Float
hx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
trackW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
thumbW) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
maxOff Float
xOff) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
maxOff
           in (Rect, Rect) -> Maybe (Rect, Rect)
forall a. a -> Maybe a
Just (Rect
hTrack, Float -> Float -> Float -> Float -> Rect
Rect Float
tx (Float
hy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2) Float
thumbW (Float
comboSbW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
4))
        else Maybe (Rect, Rect)
forall a. Maybe a
Nothing
   in (Rect
inner, Maybe (Rect, Rect)
vSb, Maybe (Rect, Rect)
hSb, Float
usableW)

-- | Combo dropdown rect: like 'selectDropRect', but with no outer margin
-- (rows start flush at the top), and the height reserves a flush bottom
-- scrollbar lane when the widest row overflows, so the horizontal bar never
-- covers the bottommost row. Must agree with 'comboScrollGeom' on when lanes
-- appear (same inputs, same formulas).
comboDropRect :: Float -> Float -> Float -> Float -> Int -> Int -> Float -> Rect
comboDropRect :: Float -> Float -> Float -> Float -> Int -> Int -> Float -> Rect
comboDropRect Float
x Float
y Float
w Float
h Int
nRows Int
nTotal Float
contentW =
  let vLaneW :: Float
vLaneW = if Int
nTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
nRows then Float
comboSbW else Float
0
      hScroll :: Bool
hScroll = Float
contentW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vLaneW) Bool -> Bool -> Bool
&& Float
contentW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0
   in Float -> Float -> Float -> Float -> Rect
Rect Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
selectDropGap) Float
w (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nRows Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
menuItemRowH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (if Bool
hScroll then Float
comboSbW else Float
0))

-- | Row index at @mouseY@ for a combo dropdown, whose rows start flush at the
-- drop rect's top (unlike 'selectDropPickIndex', which centers them).
comboDropPickIndex :: Rect -> Float -> Int -> Float -> Maybe Int
comboDropPickIndex :: Rect -> Float -> Int -> Float -> Maybe Int
comboDropPickIndex (Rect Float
_ Float
dy Float
_ Float
_) Float
itemH Int
nOpts Float
mouseY =
  let rel :: Float
rel = Float
mouseY Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dy
   in if Float
rel Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0 Bool -> Bool -> Bool
|| Float
rel Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
itemH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nOpts
        then Maybe Int
forall a. Maybe a
Nothing
        else Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
nOpts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float
rel Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
itemH Float
1))))

drawSelectOverlays :: Context -> Input -> IO ()
drawSelectOverlays :: Context -> Input -> IO ()
drawSelectOverlays Context
ctx Input
inp = do
  dropdowns <- Context -> IO [Dropdown]
openDropdowns Context
ctx
  forM_ dropdowns $ \Dropdown
dd -> do
    allow <- Context -> WidgetId -> IO Bool
widgetOverlayAllowed Context
ctx (Dropdown -> WidgetId
ddWidget Dropdown
dd)
    when allow $ do
      theme <- widgetTheme ctx (ddWidget dd)
      drawDropdownMenu ctx inp theme dd

-- | Paint one open dropdown (select or combo). The combo list clips to its
-- inner area (so x-shifted text and row fills stop at the scrollbar lanes)
-- and gets vertical / horizontal scrollbars when the filtered rows or the
-- widest row overflow the window.
drawDropdownMenu :: Context -> Input -> Theme -> Dropdown -> IO ()
drawDropdownMenu :: Context -> Input -> Theme -> Dropdown -> IO ()
drawDropdownMenu Context
ctx Input
inp Theme
theme Dropdown
dd = do
  let da :: DrawArena
da = Context -> DrawArena
ctxDrawArena Context
ctx
      fm :: FontMetrics
fm = Context -> FontMetrics
ctxFontMetrics Context
ctx
      style :: Style
style = Theme -> Style
overlayMenuStyle Theme
theme
      paintRows :: IO ()
paintRows =
        [DropdownRow] -> (DropdownRow -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (FontMetrics -> V2 -> Dropdown -> [DropdownRow]
dropdownRows FontMetrics
fm (Input -> V2
inputMousePos Input
inp) Dropdown
dd) ((DropdownRow -> IO ()) -> IO ())
-> (DropdownRow -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DropdownRow
row -> do
          let picked :: Bool
picked = DropdownRow -> Int
drIndex DropdownRow
row Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Dropdown -> Int
ddPicked Dropdown
dd
              Rect Float
_ Float
ry Float
_ Float
rh = DropdownRow -> Rect
drRect DropdownRow
row
          if DropdownRow -> Bool
drHovered DropdownRow
row
            then do
              DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (DropdownRow -> Rect
drRect DropdownRow
row) (Style -> Color
styleHoverBg Style
style)
              DrawArena -> Theme -> Rect -> IO ()
paintMenuAccent DrawArena
da Theme
theme (DropdownRow -> Rect
drRect DropdownRow
row)
            else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
picked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (DropdownRow -> Rect
drRect DropdownRow
row) (Style -> Color
styleActiveBg Style
style)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null (DropdownRow -> Text
drOption DropdownRow
row)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (_, th) <- Context -> Text -> IO (Float, Float)
ctxMeasureText Context
ctx (DropdownRow -> Text
drOption DropdownRow
row)
            pushText da fm (drTextX row) (centeredTextY fm ry rh th) (drOption row) $
              if picked then themeAccent theme else styleFg style
  DrawArena -> Theme -> Style -> Rect -> IO ()
paintMenuPanel DrawArena
da Theme
theme Style
style (Dropdown -> Rect
ddRect Dropdown
dd)
  if Dropdown -> Bool
ddCombo Dropdown
dd
    then do
      let (Rect
inner, Maybe (Rect, Rect)
vSb, Maybe (Rect, Rect)
hSb, Float
_) = Rect
-> Int
-> Int
-> Int
-> Float
-> Float
-> (Rect, Maybe (Rect, Rect), Maybe (Rect, Rect), Float)
comboScrollGeom (Dropdown -> Rect
ddRect Dropdown
dd) (Dropdown -> Int
ddComboRows Dropdown
dd) ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dropdown -> [Text]
ddOptions Dropdown
dd)) (Dropdown -> Int
ddComboWindow Dropdown
dd) (Dropdown -> Float
ddComboScrollX Dropdown
dd) (Dropdown -> Float
ddComboContentW Dropdown
dd)
          base :: Style
base = Theme -> Style
themeInput Theme
theme
          drawBar :: (Rect, Rect) -> IO ()
drawBar (Rect
track, Rect
thumb) = do
            DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da Rect
track (Style -> Theme -> Color
scrollBarTrackColor Style
base Theme
theme)
            DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
thumb Float
3 (Style -> Theme -> Color
scrollBarThumbColor Style
base Theme
theme)
      DrawArena -> Rect -> IO () -> IO ()
forall a. DrawArena -> Rect -> IO a -> IO a
withClip DrawArena
da Rect
inner IO ()
paintRows
      ((Rect, Rect) -> IO ()) -> Maybe (Rect, Rect) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Rect, Rect) -> IO ()
drawBar Maybe (Rect, Rect)
vSb
      ((Rect, Rect) -> IO ()) -> Maybe (Rect, Rect) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Rect, Rect) -> IO ()
drawBar Maybe (Rect, Rect)
hSb
    else IO ()
paintRows

collectSelectDropdownSpans :: Context -> Input -> IO [(Rect, T.Text, Color, Color, Rect)]
collectSelectDropdownSpans :: Context -> Input -> IO [(Rect, Text, Color, Color, Rect)]
collectSelectDropdownSpans Context
ctx Input
inp = do
  dropdowns <- Context -> IO [Dropdown]
openDropdowns Context
ctx
  let fm = Context -> FontMetrics
ctxFontMetrics Context
ctx
  fmap concat . forM dropdowns $ \Dropdown
dd -> do
    allow <- Context -> WidgetId -> IO Bool
widgetOverlayAllowed Context
ctx (Dropdown -> WidgetId
ddWidget Dropdown
dd)
    style <- overlayMenuStyle <$> widgetTheme ctx (ddWidget dd)
    if not allow
      then pure []
      else fmap concat . forM (dropdownRows fm (inputMousePos inp) dd) $ \DropdownRow
row ->
        if Text -> Bool
T.null (DropdownRow -> Text
drOption DropdownRow
row)
          then [(Rect, Text, Color, Color, Rect)]
-> IO [(Rect, Text, Color, Color, Rect)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          else do
            (tw, th) <- Context -> Text -> IO (Float, Float)
ctxMeasureText Context
ctx (DropdownRow -> Text
drOption DropdownRow
row)
            let Rect _ ry _ rh = drRect row
                bg
                  | DropdownRow -> Bool
drHovered DropdownRow
row = Style -> Color
styleHoverBg Style
style
                  | DropdownRow -> Int
drIndex DropdownRow
row Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Dropdown -> Int
ddPicked Dropdown
dd = Style -> Color
styleActiveBg Style
style
                  | Bool
otherwise = Style -> Color
styleBg Style
style
            pure [(Rect (drTextX row) (centeredTextY fm ry rh th) tw th, drOption row, styleFg style, bg, ddRect dd)]

tagSelectClippedSpans ::
  Rect -> Float -> Float -> Float -> Float -> FontMetrics -> [(Rect, T.Text, Color, Color)] -> [(Rect, T.Text, Color, Color, Rect)]
tagSelectClippedSpans :: Rect
-> Float
-> Float
-> Float
-> Float
-> FontMetrics
-> [(Rect, Text, Color, Color)]
-> [(Rect, Text, Color, Color, Rect)]
tagSelectClippedSpans Rect
parentClip Float
x Float
y Float
w Float
h FontMetrics
fm [(Rect, Text, Color, Color)]
spans =
  let (Float
ix, Float
_) = FontMetrics -> (Float, Float)
widgetContentInset FontMetrics
fm
      textClip :: Rect
textClip = Rect -> Rect
padTextClipRect (Float -> Float -> Float -> Float -> Rect
Rect (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ix) Float
y (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ix Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
selectChevronReserve)) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
h))
   in case Rect -> Rect -> Maybe Rect
rectIntersect Rect
parentClip Rect
textClip of
        Maybe Rect
Nothing -> []
        Just Rect
clip -> [(Rect
rect, Text
txt, Color
fg, Color
bg, Rect
clip) | (Rect
rect, Text
txt, Color
fg, Color
bg) <- [(Rect, Text, Color, Color)]
spans]