{-# LANGUAGE DataKinds #-}

-- | Multi-line text areas: content painting (lines, selection, caret and
-- scrollbars) and mouse selection.
module NanoUI.Frame.TextArea
  ( TextAreaHit (..)
  , textAreaHitForWidget
  , drawTextAreaContentWith
  , finalizeTextAreaMouse
  , collapseTextAreaSelection
  ) where

import Control.Monad (forM_, unless, when)
import Data.IORef (writeIORef)
import qualified Data.IntMap.Strict as IM
import Data.Maybe (catMaybes, isJust)
import qualified Data.Text as T
import NanoUI.Context
  ( Context (..)
  , TextInputDrag (..)
  , WidgetStore (..)
  , getStore
  , intKey
  , markDirty
  , setStore
  , setTextInputDrag
  , slotKey
  , nodeTheme
  , getsInteraction
  , InteractionState (..)
  )
import NanoUI.Draw (DrawArena, getDrawSnapScale, pushText, withClip)
import NanoUI.Font (FontMetrics, caretXIO, prepareFontMetrics, selectionSpans, textIndexAtX, widgetContentInset)
import NanoUI.Frame.Chrome (paintScrollBarLayout, textInputFocused)
import NanoUI.Frame.Hit (findNodeByWidgetId)
import NanoUI.Frame.TextArea.Content
  ( ensureTextAreaBuffer
  , isMouseOnTextAreaScrollBarAt
  , resolveTextAreaFont
  , textAreaContentMetrics
  )
import NanoUI.Frame.TextArea.Geometry
import NanoUI.Frame.TextInput (drawTextCaret, drawTextSelectionLine, normalizeTextFieldClicks)
import NanoUI.Id (WidgetId)
import NanoUI.Input
  ( Input (..)
  , inputMouseClicks
  , inputMouseDown
  , inputMousePos
  , inputMousePressed
  , inputMouseReleased
  )
import NanoUI.Layout.Arena (NodeIdx, NodeType (NodeTextArea), getNodeType, getRect, getWidgetId)
import NanoUI.Store (Slot (..))
import NanoUI.Style (Style (..), Theme, scrollBarThumbColor, scrollBarTrackColor, themePanel, themeSelection)
import NanoUI.Types (Rect (..), V2 (..), onGrid, rectContains)
import NanoUI.Widgets.TextArea (TextAreaState (..), loadTextAreaState, saveTextAreaState)
import qualified NanoUI.Widgets.TextArea as TA
import qualified NanoUI.Widgets.TextBuffer as TB
import NanoUI.Widgets.TextCommon (selectionCaretGeom, textWordBounds)

data TextAreaHit = TextAreaHit
  { TextAreaHit -> Int
tahNodeIdx :: !NodeIdx
  , TextAreaHit -> Rect
tahFieldRect :: !Rect
  , TextAreaHit -> Float
tahContentX :: !Float
  , TextAreaHit -> Float
tahLineH :: !Float
  , TextAreaHit -> Float
tahWidgetX :: !Float
  , TextAreaHit -> Float
tahWidgetY :: !Float
  , TextAreaHit -> Float
tahWidgetW :: !Float
  , TextAreaHit -> Float
tahWidgetH :: !Float
  }

-- | Editor state of the text area at @idx@, its viewport set from the field
-- clip.
loadTextAreaStateAt :: Context -> NodeIdx -> FontMetrics -> Float -> Float -> Float -> Float -> IO TA.TextAreaState
loadTextAreaStateAt :: Context
-> Int
-> FontMetrics
-> Float
-> Float
-> Float
-> Float
-> IO TextAreaState
loadTextAreaStateAt Context
ctx Int
idx FontMetrics
fm Float
x Float
y Float
w Float
h = do
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  let key = WidgetId -> Int
intKey WidgetId
wid
  store <- getStore ctx
  let initial = Text -> Int -> IntMap Text -> Text
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Text
"" Int
key (WidgetStore -> IntMap Text
storeText WidgetStore
store)
  buf <- ensureTextAreaBuffer ctx key initial
  let Rect _ _ vpW vpH = textAreaFieldClip fm (Rect x y w h)
      state0 = WidgetStore -> Int -> TextBuffer -> TextAreaState
TA.loadTextAreaStateWithBuffer WidgetStore
store Int
key TextBuffer
buf
  pure (TA.setTextAreaViewport (realToFrac vpW, realToFrac vpH) (realToFrac (textAreaLineHeight fm)) state0)

loadHitState :: Context -> TextAreaHit -> IO TA.TextAreaState
loadHitState :: Context -> TextAreaHit -> IO TextAreaState
loadHitState Context
ctx TextAreaHit
hit = do
  fm <- Context -> Int -> IO FontMetrics
resolveTextAreaFont Context
ctx (TextAreaHit -> Int
tahNodeIdx TextAreaHit
hit)
  loadTextAreaStateAt ctx (tahNodeIdx hit) fm (tahWidgetX hit) (tahWidgetY hit) (tahWidgetW hit) (tahWidgetH hit)

-- | Record the text viewport and clamp the stored scroll to the content.
-- This paint already reflects both, so the write marks nothing dirty: a
-- window resize would otherwise request a second frame that has nothing to
-- repaint.
syncTextAreaViewport :: Context -> NodeIdx -> FontMetrics -> Float -> Float -> Float -> Float -> IO ()
syncTextAreaViewport :: Context
-> Int -> FontMetrics -> Float -> Float -> Float -> Float -> IO ()
syncTextAreaViewport Context
ctx Int
idx FontMetrics
fm Float
x Float
y Float
w Float
h = do
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  (contentW, contentH) <- textAreaContentMetrics ctx idx
  -- Read after the metrics query: a cold query caches into the store.
  store <- getStore ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      Rect _ _ clipW clipH = textAreaFieldClip fm (Rect x y w h)
      bars = FontMetrics -> Rect -> Float -> Float -> TextAreaBars
textAreaBars FontMetrics
fm (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h) Float
contentW Float
contentH
      (sx, sy) = IM.findWithDefault (0, 0) (slotKey SlotTextAreaScroll key) (storePoint store)
      sx' = 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 -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
contentW Float -> Float -> Float
forall a. Num a => a -> a -> a
- TextAreaBars -> Float
tabViewW TextAreaBars
bars)) Float
sx)
      sy' = 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 -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
contentH Float -> Float -> Float
forall a. Num a => a -> a -> a
- TextAreaBars -> Float
tabViewH TextAreaBars
bars)) Float
sy)
      viewportKey = Slot -> Int -> Int
slotKey Slot
SlotTextAreaViewport Int
key
      pts0 = Int
-> (Float, Float) -> IntMap (Float, Float) -> IntMap (Float, Float)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
viewportKey (Float
clipW, Float
clipH) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
      pts1
        | Float
sx' Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
sx Bool -> Bool -> Bool
|| Float
sy' Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
sy = Int
-> (Float, Float) -> IntMap (Float, Float) -> IntMap (Float, Float)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Slot -> Int -> Int
slotKey Slot
SlotTextAreaScroll Int
key) (Float
sx', Float
sy') IntMap (Float, Float)
pts0
        | Bool
otherwise = IntMap (Float, Float)
pts0
  unless (sx' == sx && sy' == sy && IM.lookup viewportKey (storePoint store) == Just (clipW, clipH)) $
    writeIORef (ctxStore ctx) $! store {storePoint = pts1}

-- | Snap a text-area scroll offset to the device pixel grid, the same grid
-- 'pushText' snaps to, so line pens and hit-testing stay in lockstep (and in
-- agreement with each other) while the text area scrolls. The raw 'Double'
-- offset keeps sub-pixel wheel deltas; only the applied value is quantized.
textAreaSnap :: DrawArena -> IO (Float -> Float)
textAreaSnap :: DrawArena -> IO (Float -> Float)
textAreaSnap DrawArena
da = Float -> Float -> Float
onGrid (Float -> Float -> Float) -> IO Float -> IO (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawArena -> IO Float
getDrawSnapScale DrawArena
da

-- | The selection highlight on the rows between @firstRow@ and @lastRow@,
-- the ones in view.
drawTextAreaSelectionLines :: DrawArena -> Int -> Int -> TA.TextAreaState -> Rect -> FontMetrics -> Theme -> IO ()
drawTextAreaSelectionLines :: DrawArena
-> Int
-> Int
-> TextAreaState
-> Rect
-> FontMetrics
-> Theme
-> IO ()
drawTextAreaSelectionLines DrawArena
da Int
firstRow Int
lastRow TextAreaState
state (Rect Float
fieldX Float
fieldY Float
_ Float
_) FontMetrics
fm Theme
theme = do
  snap <- DrawArena -> IO (Float -> Float)
textAreaSnap DrawArena
da
  let anchor = TextAreaState -> Cursor
TA.selectionAnchor TextAreaState
state
      cursor = TextBuffer -> Cursor
TB.getCursor (TextAreaState -> TextBuffer
TA.buffer TextAreaState
state)
  when (anchor /= cursor) $ do
    let (lo, hi) = TB.selectionRange anchor cursor
        lineH = FontMetrics -> Float
textAreaLineHeight FontMetrics
fm
        (ix, iy) = widgetContentInset fm
        (scrollX, scrollY) = TA.scrollOffset state
        scrollXf = Float -> Float
snap (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
scrollX)
        scrollYf = Float -> Float
snap (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
scrollY)
        contentTop = Float
fieldY Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
iy
        selBg = Theme -> Color
themeSelection Theme
theme
        loRow = Cursor -> Int
TB.cursorRow Cursor
lo
        hiRow = Cursor -> Int
TB.cursorRow Cursor
hi
    forM_ [max loRow firstRow .. min hiRow lastRow] $ \Int
row -> do
      let line :: Text
line = Int -> TextBuffer -> Text
TB.lineAt Int
row (TextAreaState -> TextBuffer
TA.buffer TextAreaState
state)
          clampCol :: Int -> Int
clampCol Int
c = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Text -> Int
T.length Text
line) Int
c)
          startCol :: Int
startCol = Int -> Int
clampCol (if Int
row Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
loRow then Cursor -> Int
TB.cursorCol Cursor
lo else Int
0)
          endCol :: Int
endCol = Int -> Int
clampCol (if Int
row Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
hiRow then Cursor -> Int
TB.cursorCol Cursor
hi else Text -> Int
T.length Text
line)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
startCol Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
endCol) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
line
        let ly = Float
contentTop Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
row Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lineH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
scrollYf
        forM_ (selectionSpans prepared line startCol endCol) $ \(Float
wLo, Float
wHi) ->
          DrawArena -> Float -> Float -> Float -> Float -> Color -> IO ()
drawTextSelectionLine DrawArena
da (Float
fieldX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ix Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
wLo Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
scrollXf) Float
ly (Float
wHi Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
wLo) (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
4 Float
lineH) Color
selBg

-- | Text-area content with the node font already resolved, so a paint pass
-- that also needs it (for the field frame) resolves it once.
drawTextAreaContentWith :: DrawArena -> Context -> FontMetrics -> NodeIdx -> Float -> Float -> Float -> Float -> Style -> IO ()
drawTextAreaContentWith :: DrawArena
-> Context
-> FontMetrics
-> Int
-> Float
-> Float
-> Float
-> Float
-> Style
-> IO ()
drawTextAreaContentWith DrawArena
da Context
ctx FontMetrics
fm Int
idx Float
x Float
y Float
w Float
h Style
style = do
  snap <- DrawArena -> IO (Float -> Float)
textAreaSnap DrawArena
da
  syncTextAreaViewport ctx idx fm x y w h
  focus <- textInputFocused ctx idx
  theme <- nodeTheme ctx idx
  let field = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
      lineH = FontMetrics -> Float
textAreaLineHeight FontMetrics
fm
      Rect clipX contentTop clipW clipH = textAreaFieldClip fm field
      fg = Style -> Color
styleFg Style
style
  state <- loadTextAreaStateAt ctx idx fm x y w h
  (contentW, contentH) <- textAreaContentMetrics ctx idx
  let buf = TextAreaState -> TextBuffer
TA.buffer TextAreaState
state
      (scrollX, scrollY) = TA.scrollOffset state
      scrollXf = Float -> Float
snap (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
scrollX)
      scrollYf = Float -> Float
snap (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
scrollY)
      contentX = Float
clipX Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
scrollXf
      layouts = FontMetrics
-> Rect
-> Float
-> Float
-> Float
-> Float
-> TextAreaScrollBarLayouts
textAreaScrollBarLayouts FontMetrics
fm Rect
field Float
contentW Float
contentH Float
scrollXf Float
scrollYf
      textClip =
        Float -> Float -> Float -> Float -> Rect
Rect
          Float
clipX
          Float
contentTop
          (if Maybe ScrollBarLayout -> Bool
forall a. Maybe a -> Bool
isJust (TextAreaScrollBarLayouts -> Maybe ScrollBarLayout
tasbVertical TextAreaScrollBarLayouts
layouts) then Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
clipW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
textAreaBarLane) else Float
clipW)
          (if Maybe ScrollBarLayout -> Bool
forall a. Maybe a -> Bool
isJust (TextAreaScrollBarLayouts -> Maybe ScrollBarLayout
tasbHorizontal TextAreaScrollBarLayouts
layouts) then Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
clipH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
textAreaBarLane) else Float
clipH)
      -- Only the rows in view are read, so painting costs the same however
      -- long the document is.
      rowAt Float
py = Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
contentTop Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
scrollYf) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 Float
lineH) :: Int
      firstRow = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Float -> Int
rowAt Float
y)
      lastRow = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (TextBuffer -> Int
TB.getLineCount TextBuffer
buf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Float -> Int
rowAt (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h))
  withClip da textClip $ do
    when focus $
      drawTextAreaSelectionLines da firstRow lastRow state field fm theme
    forM_ [firstRow .. lastRow] $ \Int
row -> do
      let line :: Text
line = Int -> TextBuffer -> Text
TB.lineAt Int
row TextBuffer
buf
          ly :: Float
ly = Float
contentTop Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
row Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lineH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
scrollYf
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
line) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        DrawArena
-> FontMetrics -> Float -> Float -> Text -> Color -> IO ()
pushText DrawArena
da FontMetrics
fm Float
contentX Float
ly Text
line Color
fg
    when focus $ do
      let TB.Cursor row col = TB.getCursor buf
          currentLine = Int -> TextBuffer -> Text
TB.lineAt Int
row TextBuffer
buf
      pw <- caretXIO fm currentLine col
      let (caretX, caretY, caretH) = selectionCaretGeom contentX (contentTop + fromIntegral row * lineH - scrollYf) pw lineH
      drawTextCaret da caretX caretY caretH fg
  let base = Theme -> Style
themePanel Theme
theme
  mapM_
    (paintScrollBarLayout da (scrollBarTrackColor base theme) (scrollBarThumbColor base theme))
    (catMaybes [tasbVertical layouts, tasbHorizontal layouts])

textAreaHitForWidget :: Context -> WidgetId -> IO (Maybe TextAreaHit)
textAreaHitForWidget :: Context -> WidgetId -> IO (Maybe TextAreaHit)
textAreaHitForWidget Context
ctx WidgetId
wid = do
  mIdx <- Context -> WidgetId -> IO (Maybe Int)
findNodeByWidgetId Context
ctx WidgetId
wid
  case mIdx of
    Maybe Int
Nothing -> Maybe TextAreaHit -> IO (Maybe TextAreaHit)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TextAreaHit
forall a. Maybe a
Nothing
    Just Int
idx -> do
      nt <- NodeArena -> Int -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      if nt /= NodeTextArea
        then pure Nothing
        else do
          (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
          fm <- resolveTextAreaFont ctx idx
          let field = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
              Rect clipX _ _ _ = textAreaFieldClip fm field
          pure
            ( Just
                TextAreaHit
                  { tahNodeIdx = idx
                  , tahFieldRect = field
                  , tahContentX = clipX
                  , tahLineH = textAreaLineHeight fm
                  , tahWidgetX = x
                  , tahWidgetY = y
                  , tahWidgetW = w
                  , tahWidgetH = h
                  }
            )

textAreaCursorAt :: Context -> TA.TextAreaState -> TextAreaHit -> V2 -> IO (Int, Int)
textAreaCursorAt :: Context -> TextAreaState -> TextAreaHit -> V2 -> IO (Int, Int)
textAreaCursorAt Context
ctx TextAreaState
state TextAreaHit
hit (V2 Float
mouseX Float
mouseY) = do
  snap <- DrawArena -> IO (Float -> Float)
textAreaSnap (Context -> DrawArena
ctxDrawArena Context
ctx)
  fm <- resolveTextAreaFont ctx (tahNodeIdx hit)
  let buf = TextAreaState -> TextBuffer
TA.buffer TextAreaState
state
      lineCount = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (TextBuffer -> Int
TB.getLineCount TextBuffer
buf)
      (scrollX, scrollY) = TA.scrollOffset state
      scrollXf = Float -> Float
snap (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
scrollX)
      scrollYf = Float -> Float
snap (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
scrollY)
      (_, iy) = widgetContentInset fm
      Rect _ fieldY _ _ = tahFieldRect hit
      relY = Float
mouseY Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
fieldY Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
iy) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
scrollYf
      row = 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
lineCount 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
relY Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (TextAreaHit -> Float
tahLineH TextAreaHit
hit))))
      line = Int -> TextBuffer -> Text
TB.lineAt Int
row TextBuffer
buf
  prepared <- prepareFontMetrics fm line
  pure (row, textIndexAtX prepared line (max 0 (mouseX - (tahContentX hit - scrollXf))))

updateTextAreaSelection :: Context -> WidgetId -> TextAreaHit -> TB.Cursor -> TB.Cursor -> IO ()
updateTextAreaSelection :: Context -> WidgetId -> TextAreaHit -> Cursor -> Cursor -> IO ()
updateTextAreaSelection Context
ctx WidgetId
wid TextAreaHit
hit Cursor
anchor Cursor
cursor = do
  state0 <- Context -> TextAreaHit -> IO TextAreaState
loadHitState Context
ctx TextAreaHit
hit
  store <- getStore ctx
  -- A selection change keeps the stored text, so the document is not rejoined.
  let key = WidgetId -> Int
intKey WidgetId
wid
      text = Text -> Int -> IntMap Text -> Text
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Text
"" Int
key (WidgetStore -> IntMap Text
storeText WidgetStore
store)
  setStore ctx (TA.saveTextAreaState key text (TA.setTextAreaSelection anchor cursor state0) store)
  markDirty ctx

applyTextAreaClick :: Context -> WidgetId -> TextAreaHit -> Int -> Int -> Int -> IO ()
applyTextAreaClick :: Context -> WidgetId -> TextAreaHit -> Int -> Int -> Int -> IO ()
applyTextAreaClick Context
ctx WidgetId
wid TextAreaHit
hit Int
row Int
col Int
clicks
  | Int
clicks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 = do
      state <- Context -> TextAreaHit -> IO TextAreaState
loadHitState Context
ctx TextAreaHit
hit
      updateTextAreaSelection ctx wid hit (TB.Cursor 0 0) (TB.documentEnd (TA.buffer state))
  | Int
clicks Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = do
      state <- Context -> TextAreaHit -> IO TextAreaState
loadHitState Context
ctx TextAreaHit
hit
      let (lo, hi) = textWordBounds (TB.lineAt row (TA.buffer state)) col
      updateTextAreaSelection ctx wid hit (TB.Cursor row lo) (TB.Cursor row hi)
  | Bool
otherwise =
      Context -> WidgetId -> TextAreaHit -> Cursor -> Cursor -> IO ()
updateTextAreaSelection Context
ctx WidgetId
wid TextAreaHit
hit (Int -> Int -> Cursor
TB.Cursor Int
row Int
col) (Int -> Int -> Cursor
TB.Cursor Int
row Int
col)

applyTextAreaDrag :: Context -> WidgetId -> TextAreaHit -> Int -> Int -> Int -> Int -> Int -> IO ()
applyTextAreaDrag :: Context
-> WidgetId
-> TextAreaHit
-> Int
-> Int
-> Int
-> Int
-> Int
-> IO ()
applyTextAreaDrag Context
ctx WidgetId
wid TextAreaHit
hit Int
anchorRow Int
anchorCol Int
row Int
col Int
clicks
  | Int
clicks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 = Context -> WidgetId -> TextAreaHit -> Int -> Int -> Int -> IO ()
applyTextAreaClick Context
ctx WidgetId
wid TextAreaHit
hit Int
row Int
col Int
clicks
  | Int
clicks Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = do
      state <- Context -> TextAreaHit -> IO TextAreaState
loadHitState Context
ctx TextAreaHit
hit
      let buf = TextAreaState -> TextBuffer
TA.buffer TextAreaState
state
          (a0, a1) = textWordBounds (TB.lineAt anchorRow buf) anchorCol
          (c0, c1) = textWordBounds (TB.lineAt row buf) col
      updateTextAreaSelection ctx wid hit (TB.Cursor anchorRow (min a0 c0)) (TB.Cursor row (max a1 c1))
  | Bool
otherwise =
      Context -> WidgetId -> TextAreaHit -> Cursor -> Cursor -> IO ()
updateTextAreaSelection Context
ctx WidgetId
wid TextAreaHit
hit (Int -> Int -> Cursor
TB.Cursor Int
anchorRow Int
anchorCol) (Int -> Int -> Cursor
TB.Cursor Int
row Int
col)

-- | Mouse selection in text area @wid@: press (with word and document
-- multi-clicks) and drag. Presses on the scrollbars are left to the scroller.
finalizeTextAreaMouse :: Context -> Input -> WidgetId -> IO ()
finalizeTextAreaMouse :: Context -> Input -> WidgetId -> IO ()
finalizeTextAreaMouse Context
ctx Input
inp WidgetId
wid = do
  mHit <- Context -> WidgetId -> IO (Maybe TextAreaHit)
textAreaHitForWidget Context
ctx WidgetId
wid
  case mHit of
    Maybe TextAreaHit
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just TextAreaHit
hit -> do
      let mouse :: V2
mouse = Input -> V2
inputMousePos Input
inp
      onScroll <- Context -> Int -> V2 -> IO Bool
isMouseOnTextAreaScrollBarAt Context
ctx (TextAreaHit -> Int
tahNodeIdx TextAreaHit
hit) V2
mouse
      let cursorAtMouse = do
            state <- Context -> TextAreaHit -> IO TextAreaState
loadHitState Context
ctx TextAreaHit
hit
            textAreaCursorAt ctx state hit mouse
      if inputMousePressed inp && rectContains (tahFieldRect hit) mouse && not onScroll
        then do
          (row, col) <- cursorAtMouse
          clicks <- normalizeTextFieldClicks ctx wid 0 row col True (max 1 (inputMouseClicks inp))
          applyTextAreaClick ctx wid hit row col clicks
          setTextInputDrag ctx (Just (TextInputDrag wid 0 row col True clicks))
        else do
          mDrag <- getsInteraction ctx isTextInputDrag
          case mDrag of
            Just TextInputDrag
drag
              | TextInputDrag -> WidgetId
textInputDragWidget TextInputDrag
drag WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
                  , TextInputDrag -> Bool
textInputDragMultiline TextInputDrag
drag
                  , Input -> Bool
inputMouseDown Input
inp Bool -> Bool -> Bool
|| Input -> Bool
inputMouseReleased Input
inp -> do
                  (row, col) <- IO (Int, Int)
cursorAtMouse
                  applyTextAreaDrag
                    ctx
                    wid
                    hit
                    (textInputDragAnchorRow drag)
                    (textInputDragAnchorCol drag)
                    row
                    col
                    (textInputDragClicks drag)
            Maybe TextInputDrag
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

collapseTextAreaSelection :: Context -> WidgetId -> IO ()
collapseTextAreaSelection :: Context -> WidgetId -> IO ()
collapseTextAreaSelection Context
ctx WidgetId
wid = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      text = Text -> Int -> IntMap Text -> Text
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Text
"" Int
key (WidgetStore -> IntMap Text
storeText WidgetStore
store)
      row = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotTextAreaRow Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      col = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotTextAreaCol Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      state = WidgetStore -> Int -> Text -> TextAreaState
loadTextAreaState WidgetStore
store Int
key Text
text
  setStore ctx (saveTextAreaState key text state {selectionAnchor = TB.Cursor row col} store)