{-# LANGUAGE DataKinds #-}

-- | Single-line text fields: field geometry, horizontal scroll, caret and
-- selection painting, and mouse selection. Also holds the click-count and
-- caret primitives the text area shares.
module NanoUI.Frame.TextInput
  ( textInputFieldRect
  , textInputFieldTextClip
  , nodeTextFieldGeom
  , tagTextInputClippedSpans
  , syncTextInputScroll
  , FieldEdit
  , readFieldEdit
  , drawTextInputSelection
  , drawTextInputCaret
  , drawTextCaret
  , drawTextSelectionLine
  , searchClearHit
  , normalizeTextFieldClicks
  , finalizeTextInputMouse
  , collapseTextInputSelection
  ) where

import Control.Monad (forM_, when)
import qualified Data.IntMap.Strict as IM
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import NanoUI.Context
  ( Context (..)
  , TextFieldClickCell (..)
  , TextInputDrag (..)
  , WidgetStore (..)
  , getStore
  , intKey
  , markDirty
  , setStore
  , setTextInputDrag
  , Slot (..)
  , slotKey
  , nodeTheme
  , InteractionState (..)
  , getsInteraction
  , modifyInteraction
  )
import NanoUI.Draw (DrawArena, pushRect)
import NanoUI.Font (FontMetrics (..), caretXIO, centeredTextY, lineWidthIO, prepareFontMetrics, selectionSpans, textIndexAtX, widgetContentInset)
import NanoUI.Frame.Chrome (textInputFocused, textInputValue)
import NanoUI.Frame.Hit (findNodeByWidgetId)
import NanoUI.Frame.Node (nodeFontMetrics)
import NanoUI.Frame.Scroll.Geometry (padTextClipRect)
import NanoUI.Id (WidgetId)
import NanoUI.Input
  ( Input (..)
  , inputMouseClicks
  , inputMouseDown
  , inputMousePos
  , inputMousePressed
  , inputMouseReleased
  )
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (NodeTextInput)
  , getNodeType
  , getOptions
  , getRect
  , getStyleIdx
  , getWidgetId
  )
import NanoUI.Style (themeSelection)
import NanoUI.Types (Color (..), Rect (..), V2 (..), rectContains, rectIntersect, rectOverlapArea, rectW)
import NanoUI.WidgetText
  ( comboTextClip
  , numericTextClip
  , searchFieldIconRects
  , searchFieldTextClip
  , textInputNumericMode
  , textInputFieldHeight
  , textInputSearchMode
  , textInputSelectableMode
  )
import NanoUI.Widgets.TextCommon
  ( selectionCaretGeom
  , textSelectionForClick
  , textSelectionForDrag
  )

textInputFieldRect :: FontMetrics -> Float -> Float -> Float -> Float -> Rect
textInputFieldRect :: FontMetrics -> Float -> Float -> Float -> Float -> Rect
textInputFieldRect FontMetrics
fm Float
x Float
y Float
w Float
h =
  let fieldH :: Float
fieldH = if Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
h else FontMetrics -> Float
textInputFieldHeight FontMetrics
fm
   in Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
fieldH

textInputFieldTextClip :: FontMetrics -> Rect -> Rect
textInputFieldTextClip :: FontMetrics -> Rect -> Rect
textInputFieldTextClip FontMetrics
fm (Rect Float
fx Float
fy Float
fw Float
fh) =
  let (Float
ix, Float
iy) = FontMetrics -> (Float, Float)
widgetContentInset FontMetrics
fm
   in Float -> Float -> Float -> Float -> Rect
Rect (Float
fx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ix) (Float
fy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
iy) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
fw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ix)) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
fh Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
iy))

-- | Resolve the box a field paints/hits and the clip its text is confined to.
-- Search fields are caption-less: the whole node rect is the box and text is
-- clipped around the magnifier / clear chrome. Combo boxes (search fields
-- carrying dropdown options) clip to the left of the chevron instead.
nodeTextFieldGeom :: Context -> NodeIdx -> Float -> Float -> Float -> Float -> IO (Rect, Rect)
nodeTextFieldGeom :: Context
-> Int -> Float -> Float -> Float -> Float -> IO (Rect, Rect)
nodeTextFieldGeom Context
ctx Int
idx Float
x Float
y Float
w Float
h = do
  si <- NodeArena -> Int -> IO Int
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  opts <- getOptions (ctxNodeArena ctx) idx
  let fm = Context -> FontMetrics
ctxFontMetrics Context
ctx
      box = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
      field = FontMetrics -> Float -> Float -> Float -> Float -> Rect
textInputFieldRect FontMetrics
fm Float
x Float
y Float
w Float
h
  pure $
    if textInputSelectableMode si
      then (box, box)
      else
        if textInputNumericMode si
          then (box, numericTextClip fm x y w h)
          else
            if textInputSearchMode si
              then (box, if null opts then searchFieldTextClip fm x y w h else comboTextClip fm x y w h)
              else (field, textInputFieldTextClip fm field)

-- | Whether the pointer is over the clear (×) button of a non-empty search
-- field. Search fields reserve that slot even when empty, but the button is
-- only active when there is text to clear.
searchClearHit :: Context -> WidgetId -> V2 -> IO Bool
searchClearHit :: Context -> WidgetId -> V2 -> IO Bool
searchClearHit Context
ctx WidgetId
wid V2
mouse = do
  mIdx <- Context -> WidgetId -> IO (Maybe Int)
findNodeByWidgetId Context
ctx WidgetId
wid
  case mIdx of
    Maybe Int
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Int
idx -> do
      si <- NodeArena -> Int -> IO Int
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      opts <- getOptions (ctxNodeArena ctx) idx
      if not (textInputSearchMode si) || not (null opts)
        then pure False
        else do
          value <- textInputValue ctx idx
          if T.null value
            then pure False
            else do
              (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
              let (_, clearRect) = searchFieldIconRects (ctxFontMetrics ctx) x y w h
              pure (rectContains clearRect mouse)

-- | Clear a search field. The debounced pulse picks the empty text up as an
-- immediate (empty) commit on the next frame.
clearSearchField :: Context -> WidgetId -> IO ()
clearSearchField :: Context -> WidgetId -> IO ()
clearSearchField Context
ctx WidgetId
wid = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      storeInt' =
        Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Slot -> Int -> Int
slotKey Slot
SlotAnchor Int
key) Int
0 (IntMap Int -> IntMap Int) -> IntMap Int -> IntMap Int
forall a b. (a -> b) -> a -> b
$
          Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Slot -> Int -> Int
slotKey Slot
SlotCursor Int
key) Int
0 (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      store' = WidgetStore
store {storeText = IM.insert key "" (storeText store), storeInt = storeInt'}
  setStore ctx store'
  markDirty ctx

tagTextInputClippedSpans ::
  Rect -> Float -> Float -> Float -> Float -> FontMetrics -> [(Rect, T.Text, Color, Color)] -> [(Rect, T.Text, Color, Color, Rect)]
tagTextInputClippedSpans :: Rect
-> Float
-> Float
-> Float
-> Float
-> FontMetrics
-> [(Rect, Text, Color, Color)]
-> [(Rect, Text, Color, Color, Rect)]
tagTextInputClippedSpans Rect
parentClip Float
x Float
y Float
w Float
h FontMetrics
fm [(Rect, Text, Color, Color)]
spans =
  let fieldClip :: Rect
fieldClip = FontMetrics -> Rect -> Rect
textInputFieldTextClip FontMetrics
fm (FontMetrics -> Float -> Float -> Float -> Float -> Rect
textInputFieldRect FontMetrics
fm Float
x Float
y Float
w Float
h)
      labelClip :: Rect
labelClip = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w (FontMetrics -> Float
fmLineHeight FontMetrics
fm)
      tagOne :: (Rect, Text, Color, Color)
-> Maybe (Rect, Text, Color, Color, Rect)
tagOne (Rect
rect, Text
txt, Color
fg, Color
bg) =
        let clipRect :: Rect
clipRect = Rect -> Rect
padTextClipRect Rect
rect
            isField :: Bool
isField = Rect -> Rect -> Float
rectOverlapArea Rect
fieldClip Rect
clipRect Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Rect -> Rect -> Float
rectOverlapArea Rect
labelClip Rect
clipRect
            area :: Rect
area = if Bool
isField then Rect
fieldClip else Rect
labelClip
         in (Rect
rect, Text
txt, Color
fg, Color
bg,) (Rect -> (Rect, Text, Color, Color, Rect))
-> Maybe Rect -> Maybe (Rect, Text, Color, Color, Rect)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rect -> Rect -> Maybe Rect
rectIntersect Rect
area Rect
clipRect Maybe Rect -> (Rect -> Maybe Rect) -> Maybe Rect
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rect -> Rect -> Maybe Rect
rectIntersect Rect
parentClip)
   in ((Rect, Text, Color, Color)
 -> Maybe (Rect, Text, Color, Color, Rect))
-> [(Rect, Text, Color, Color)]
-> [(Rect, Text, Color, Color, Rect)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Rect, Text, Color, Color)
-> Maybe (Rect, Text, Color, Color, Rect)
tagOne [(Rect, Text, Color, Color)]
spans

drawTextCaret :: DrawArena -> Float -> Float -> Float -> Color -> IO ()
drawTextCaret :: DrawArena -> Float -> Float -> Float -> Color -> IO ()
drawTextCaret DrawArena
da Float
caretX Float
caretY Float
caretH Color
fg =
  DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
caretX Float
caretY Float
1 Float
caretH) Color
fg

drawTextSelectionLine :: DrawArena -> Float -> Float -> Float -> Float -> Color -> IO ()
drawTextSelectionLine :: DrawArena -> Float -> Float -> Float -> Float -> Color -> IO ()
drawTextSelectionLine DrawArena
da Float
selX Float
selY Float
selW Float
selH Color
selBg =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
selW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
selX Float
selY (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 Float
selW) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
4 Float
selH)) Color
selBg

computeTextInputScroll :: FontMetrics -> Float -> Text -> Int -> Float -> Bool -> IO Float
computeTextInputScroll :: FontMetrics -> Float -> Text -> Int -> Float -> Bool -> IO Float
computeTextInputScroll FontMetrics
fm Float
viewportW Text
value Int
cursor Float
oldScroll Bool
isFocused
  | Bool -> Bool
not Bool
isFocused = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0
  | Float
viewportW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0
  | Bool
otherwise = do
      caretRelX <- FontMetrics -> Text -> Int -> IO Float
caretXIO FontMetrics
fm Text
value Int
cursor
      totalTextW <- lineWidthIO fm value
      let maxScroll = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
totalTextW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
viewportW)
          s0
            | Float
caretRelX Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
oldScroll = Float
caretRelX
            | Float
caretRelX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
oldScroll Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
viewportW = Float
caretRelX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
viewportW
            | Bool
otherwise = Float
oldScroll
      pure (max 0 (min maxScroll s0))

syncTextInputScroll :: Context -> NodeIdx -> Float -> Float -> Float -> Float -> IO Float
syncTextInputScroll :: Context -> Int -> Float -> Float -> Float -> Float -> IO Float
syncTextInputScroll Context
ctx Int
idx Float
x Float
y Float
w Float
h = do
  si <- NodeArena -> Int -> IO Int
getStyleIdx (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  if textInputSelectableMode si
    then pure 0
    else do
      wid <- getWidgetId (ctxNodeArena ctx) idx
      store <- getStore ctx
      let key = WidgetId -> Int
intKey WidgetId
wid
      value <- textInputValue ctx idx
      focus <- textInputFocused ctx idx
      (_, clip) <- nodeTextFieldGeom ctx idx x y w h
      let cursor = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (Text -> Int
T.length Text
value) (Slot -> Int -> Int
slotKey Slot
SlotCursor Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
          oldScroll = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 (Slot -> Int -> Int
slotKey Slot
SlotTextInputScroll Int
key) (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
      newScroll <- computeTextInputScroll (ctxFontMetrics ctx) (rectW clip) value cursor oldScroll focus
      when (newScroll /= oldScroll) $
        setStore ctx (store {storeFloat = IM.insert (slotKey SlotTextInputScroll key) newScroll (storeFloat store)})
      pure newScroll

-- | What a focused single-line field paints its selection and caret from: the
-- displayed value, cursor and anchor, the node font, the field box's top and
-- height, and the x its text starts at with the scroll applied.
data FieldEdit = FieldEdit !Text !Int !Int !FontMetrics !Float !Float !Float

-- | Editing state of field @idx@ at @x y w h@ scrolled by @scrollX@ (see
-- 'syncTextInputScroll'), or Nothing while it is unfocused.
readFieldEdit :: Context -> NodeIdx -> Float -> Float -> Float -> Float -> Float -> IO (Maybe FieldEdit)
readFieldEdit :: Context
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO (Maybe FieldEdit)
readFieldEdit Context
ctx Int
idx Float
x Float
y Float
w Float
h Float
scrollX = do
  focus <- Context -> Int -> IO Bool
textInputFocused Context
ctx Int
idx
  if not focus
    then pure Nothing
    else do
      value <- textInputValue ctx idx
      wid <- getWidgetId (ctxNodeArena ctx) idx
      store <- getStore ctx
      (Rect _ boxY _ boxH, Rect clipX _ _ _) <- nodeTextFieldGeom ctx idx x y w h
      fm <- nodeFontMetrics ctx idx
      let key = WidgetId -> Int
intKey WidgetId
wid
          !cursor = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (Text -> Int
T.length Text
value) (Slot -> Int -> Int
slotKey Slot
SlotCursor Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
          !anchor = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
cursor (Slot -> Int -> Int
slotKey Slot
SlotAnchor Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      pure $! Just (FieldEdit value cursor anchor fm boxY boxH (clipX - scrollX))

drawTextInputSelection :: DrawArena -> Context -> NodeIdx -> FieldEdit -> IO ()
drawTextInputSelection :: DrawArena -> Context -> Int -> FieldEdit -> IO ()
drawTextInputSelection DrawArena
da Context
ctx Int
idx (FieldEdit Text
value Int
cursor Int
anchor FontMetrics
fm Float
boxY Float
boxH Float
textX) = do
  let selLo :: Int
selLo = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
anchor Int
cursor
      selHi :: Int
selHi = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
anchor Int
cursor
      lineH :: Float
lineH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
selLo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
selHi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    theme <- Context -> Int -> IO Theme
nodeTheme Context
ctx Int
idx
    prepared <- prepareFontMetrics fm value
    forM_ (selectionSpans prepared value selLo selHi) $ \(Float
wLo, Float
wHi) ->
      DrawArena -> Float -> Float -> Float -> Float -> Color -> IO ()
drawTextSelectionLine
        DrawArena
da
        (Float
textX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
wLo)
        (FontMetrics -> Float -> Float -> Float -> Float
centeredTextY FontMetrics
fm Float
boxY Float
boxH Float
lineH)
        (Float
wHi Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
wLo)
        Float
lineH
        (Theme -> Color
themeSelection Theme
theme)

drawTextInputCaret :: DrawArena -> FieldEdit -> Color -> IO ()
drawTextInputCaret :: DrawArena -> FieldEdit -> Color -> IO ()
drawTextInputCaret DrawArena
da (FieldEdit Text
value Int
cursor Int
_ FontMetrics
fm Float
boxY Float
boxH Float
textX) Color
fg = do
  let lineH :: Float
lineH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
  pw <- FontMetrics -> Text -> Int -> IO Float
caretXIO FontMetrics
fm Text
value Int
cursor
  let (caretX, caretY, caretH) =
        selectionCaretGeom textX (centeredTextY fm boxY boxH lineH) pw lineH
  drawTextCaret da caretX caretY caretH fg

updateTextInputSelection :: Context -> WidgetId -> Int -> Int -> IO ()
updateTextInputSelection :: Context -> WidgetId -> Int -> Int -> IO ()
updateTextInputSelection Context
ctx WidgetId
wid Int
anchor Int
cursor = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      oldAnchor = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
cursor (Slot -> Int -> Int
slotKey Slot
SlotAnchor Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      oldCursor = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotCursor Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
  when (oldAnchor /= anchor || oldCursor /= cursor) $ do
    setStore
      ctx
      ( store
          { storeInt =
              IM.insert (slotKey SlotAnchor key) anchor $
                IM.insert (slotKey SlotCursor key) cursor (storeInt store)
          }
      )
    markDirty ctx

-- | Field box, text origin x (scroll applied), value and font of a single-line
-- field.
textInputGeomForWidget :: Context -> WidgetId -> IO (Maybe (Rect, Float, Text, FontMetrics))
textInputGeomForWidget :: Context -> WidgetId -> IO (Maybe (Rect, Float, Text, FontMetrics))
textInputGeomForWidget Context
ctx WidgetId
wid = do
  mIdx <- Context -> WidgetId -> IO (Maybe Int)
findNodeByWidgetId Context
ctx WidgetId
wid
  case mIdx of
    Maybe Int
Nothing -> Maybe (Rect, Float, Text, FontMetrics)
-> IO (Maybe (Rect, Float, Text, FontMetrics))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Rect, Float, Text, FontMetrics)
forall a. Maybe a
Nothing
    Just Int
idx -> do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      if nt /= NodeTextInput
        then pure Nothing
        else do
          (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
          (field, Rect clipX _ _ _) <- nodeTextFieldGeom ctx idx x y w h
          scrollX <- syncTextInputScroll ctx idx x y w h
          fm <- nodeFontMetrics ctx idx
          value <- textInputValue ctx idx
          pure (Just (field, clipX - scrollX, value, fm))

-- | Mouse selection in single-line field @wid@: click (with word and line
-- multi-clicks), drag, and the search clear button. False when @wid@ is not a
-- single-line field.
finalizeTextInputMouse :: Context -> Input -> WidgetId -> IO Bool
finalizeTextInputMouse :: Context -> Input -> WidgetId -> IO Bool
finalizeTextInputMouse Context
ctx Input
inp WidgetId
wid = do
  mGeom <- Context -> WidgetId -> IO (Maybe (Rect, Float, Text, FontMetrics))
textInputGeomForWidget Context
ctx WidgetId
wid
  case mGeom of
    Maybe (Rect, Float, Text, FontMetrics)
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just (Rect
fieldRect, Float
contentX, Text
value, FontMetrics
fm) -> do
      let mouse :: V2
mouse@(V2 Float
mouseX Float
_) = Input -> V2
inputMousePos Input
inp
          charAt :: IO Int
charAt = do
            prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
value
            pure (textIndexAtX prepared value (max 0 (mouseX - contentX)))
      if Input -> Bool
inputMousePressed Input
inp Bool -> Bool -> Bool
&& Rect -> V2 -> Bool
rectContains Rect
fieldRect V2
mouse
        then do
          cleared <- Context -> WidgetId -> V2 -> IO Bool
searchClearHit Context
ctx WidgetId
wid V2
mouse
          if cleared
            then clearSearchField ctx wid
            else do
              idx <- charAt
              clicks <- normalizeTextFieldClicks ctx wid idx 0 0 False (max 1 (inputMouseClicks inp))
              uncurry (updateTextInputSelection ctx wid) (textSelectionForClick value idx clicks)
              setTextInputDrag ctx (Just (TextInputDrag wid idx 0 0 False clicks))
        else do
          mDrag <- Context
-> (InteractionState -> Maybe TextInputDrag)
-> IO (Maybe TextInputDrag)
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe TextInputDrag
isTextInputDrag
          case mDrag of
            Just TextInputDrag
drag
              | TextInputDrag -> WidgetId
textInputDragWidget TextInputDrag
drag WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
                  , Bool -> Bool
not (TextInputDrag -> Bool
textInputDragMultiline TextInputDrag
drag)
                  , Input -> Bool
inputMouseDown Input
inp Bool -> Bool -> Bool
|| Input -> Bool
inputMouseReleased Input
inp -> do
                  idx <- IO Int
charAt
                  uncurry (updateTextInputSelection ctx wid) $
                    textSelectionForDrag value (textInputDragAnchor drag) idx (textInputDragClicks drag)
            Maybe TextInputDrag
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

collapseTextInputSelection :: Context -> WidgetId -> IO ()
collapseTextInputSelection :: Context -> WidgetId -> IO ()
collapseTextInputSelection Context
ctx WidgetId
wid = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      cur = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotCursor Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
  setStore ctx (store {storeInt = IM.insert (slotKey SlotAnchor key) cur (storeInt store)})

-- | Count a press as a multi-click only when it lands on the same cell as the
-- previous press; anything else restarts the count at one.
normalizeTextFieldClicks :: Context -> WidgetId -> Int -> Int -> Int -> Bool -> Int -> IO Int
normalizeTextFieldClicks :: Context -> WidgetId -> Int -> Int -> Int -> Bool -> Int -> IO Int
normalizeTextFieldClicks Context
ctx WidgetId
wid Int
flat Int
row Int
col Bool
multiline Int
rawClicks = do
  let cell :: TextFieldClickCell
cell =
        TextFieldClickCell
          { textFieldClickWidget :: WidgetId
textFieldClickWidget = WidgetId
wid
          , textFieldClickFlat :: Int
textFieldClickFlat = Int
flat
          , textFieldClickRow :: Int
textFieldClickRow = Int
row
          , textFieldClickCol :: Int
textFieldClickCol = Int
col
          , textFieldClickMultiline :: Bool
textFieldClickMultiline = Bool
multiline
          }
  if Int
rawClicks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
    then Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isTextFieldClickCell = Just cell}) IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
rawClicks
    else do
      mPrev <- Context
-> (InteractionState -> Maybe TextFieldClickCell)
-> IO (Maybe TextFieldClickCell)
forall a. Context -> (InteractionState -> a) -> IO a
getsInteraction Context
ctx InteractionState -> Maybe TextFieldClickCell
isTextFieldClickCell
      if maybe False (sameCell cell) mPrev
        then pure rawClicks
        else modifyInteraction ctx (\InteractionState
s -> InteractionState
s {isTextFieldClickCell = Just cell}) >> pure 1
  where
    sameCell :: TextFieldClickCell -> TextFieldClickCell -> Bool
sameCell TextFieldClickCell
a TextFieldClickCell
b =
      TextFieldClickCell -> WidgetId
textFieldClickWidget TextFieldClickCell
a WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== TextFieldClickCell -> WidgetId
textFieldClickWidget TextFieldClickCell
b
        Bool -> Bool -> Bool
&& TextFieldClickCell -> Bool
textFieldClickMultiline TextFieldClickCell
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== TextFieldClickCell -> Bool
textFieldClickMultiline TextFieldClickCell
b
        Bool -> Bool -> Bool
&& if TextFieldClickCell -> Bool
textFieldClickMultiline TextFieldClickCell
a
          then TextFieldClickCell -> Int
textFieldClickRow TextFieldClickCell
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TextFieldClickCell -> Int
textFieldClickRow TextFieldClickCell
b Bool -> Bool -> Bool
&& TextFieldClickCell -> Int
textFieldClickCol TextFieldClickCell
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TextFieldClickCell -> Int
textFieldClickCol TextFieldClickCell
b
          else TextFieldClickCell -> Int
textFieldClickFlat TextFieldClickCell
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TextFieldClickCell -> Int
textFieldClickFlat TextFieldClickCell
b