TextArea.hs

{-|
Module      : Monomer.Widgets.Singles.TextArea
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Input field for multiline 'Text'. Allows setting the maximum number of
characters, lines and whether the tab key should trigger focus change.

@
textArea longTextLens
@

With configuration options:

@
textArea_ longTextLens [maxLength 1000, selectOnFocus]
@
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Singles.TextArea (
  -- * Configuration
  TextAreaCfg,
  -- * Constructors
  textArea,
  textArea_,
  textAreaV,
  textAreaV_,
  textAreaD_
) where

import Control.Applicative ((<|>))
import Control.Lens hiding ((|>))
import Control.Monad (forM_, when)
import Data.Default
import Data.Foldable (toList)
import Data.Maybe
import Data.Sequence (Seq(..), (|>))
import Data.Tuple (swap)
import Data.Text (Text)
import GHC.Generics

import qualified Data.Sequence as Seq
import qualified Data.Text as T

import Monomer.Helper
import Monomer.Widgets.Containers.Scroll
import Monomer.Widgets.Single

import qualified Monomer.Lens as L

defCaretW :: Double
defCaretW = 2

defCaretMs :: Millisecond
defCaretMs = 500

{-|
Configuration options for textArea:

- 'maxLength': the maximum length of input text.
- 'maxLines': the maximum number of lines of input text.
- 'acceptTab': whether to handle tab and convert it to spaces (cancelling change
  of focus), or keep default behaviour and lose focus.
- 'selectOnFocus': Whether all input should be selected when focus is received.
- 'readOnly': Whether to prevent the user changing the input text.
- 'onFocus': event to raise when focus is received.
- 'onFocusReq': 'WidgetRequest' to generate when focus is received.
- 'onBlur': event to raise when focus is lost.
- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
- 'onChange': event to raise when the value changes.
- 'onChangeReq': 'WidgetRequest' to generate when the value changes.
-}
data TextAreaCfg s e = TextAreaCfg {
  _tacCaretWidth :: Maybe Double,
  _tacCaretMs :: Maybe Millisecond,
  _tacMaxLength :: Maybe Int,
  _tacMaxLines :: Maybe Int,
  _tacAcceptTab :: Maybe Bool,
  _tacSelectOnFocus :: Maybe Bool,
  _tacReadOnly :: Maybe Bool,
  _tacOnFocusReq :: [Path -> WidgetRequest s e],
  _tacOnBlurReq :: [Path -> WidgetRequest s e],
  _tacOnChangeReq :: [Text -> WidgetRequest s e]
}

instance Default (TextAreaCfg s e) where
  def = TextAreaCfg {
    _tacCaretWidth = Nothing,
    _tacCaretMs = Nothing,
    _tacMaxLength = Nothing,
    _tacMaxLines = Nothing,
    _tacAcceptTab = Nothing,
    _tacSelectOnFocus = Nothing,
    _tacReadOnly = Nothing,
    _tacOnFocusReq = [],
    _tacOnBlurReq = [],
    _tacOnChangeReq = []
  }

instance Semigroup (TextAreaCfg s e) where
  (<>) t1 t2 = TextAreaCfg {
    _tacCaretWidth = _tacCaretWidth t2 <|> _tacCaretWidth t1,
    _tacCaretMs = _tacCaretMs t2 <|> _tacCaretMs t1,
    _tacMaxLength = _tacMaxLength t2 <|> _tacMaxLength t1,
    _tacMaxLines = _tacMaxLines t2 <|> _tacMaxLines t1,
    _tacAcceptTab = _tacAcceptTab t2 <|> _tacAcceptTab t1,
    _tacSelectOnFocus = _tacSelectOnFocus t2 <|> _tacSelectOnFocus t1,
    _tacReadOnly = _tacReadOnly t2 <|> _tacReadOnly t1,
    _tacOnFocusReq = _tacOnFocusReq t1 <> _tacOnFocusReq t2,
    _tacOnBlurReq = _tacOnBlurReq t1 <> _tacOnBlurReq t2,
    _tacOnChangeReq = _tacOnChangeReq t1 <> _tacOnChangeReq t2
  }

instance Monoid (TextAreaCfg s e) where
  mempty = def

instance CmbCaretWidth (TextAreaCfg s e) Double where
  caretWidth w = def {
    _tacCaretWidth = Just w
  }

instance CmbCaretMs (TextAreaCfg s e) Millisecond where
  caretMs ms = def {
    _tacCaretMs = Just ms
  }

instance CmbMaxLength (TextAreaCfg s e) where
  maxLength len = def {
    _tacMaxLength = Just len
  }

instance CmbMaxLines (TextAreaCfg s e) where
  maxLines lines = def {
    _tacMaxLines = Just lines
  }

instance CmbAcceptTab (TextAreaCfg s e) where
  acceptTab_ accept = def {
    _tacAcceptTab = Just accept
  }

instance CmbSelectOnFocus (TextAreaCfg s e) where
  selectOnFocus_ sel = def {
    _tacSelectOnFocus = Just sel
  }

instance CmbReadOnly (TextAreaCfg s e) where
  readOnly_ ro = def {
    _tacReadOnly = Just ro
  }

instance WidgetEvent e => CmbOnFocus (TextAreaCfg s e) e Path where
  onFocus fn = def {
    _tacOnFocusReq = [RaiseEvent . fn]
  }

instance CmbOnFocusReq (TextAreaCfg s e) s e Path where
  onFocusReq req = def {
    _tacOnFocusReq = [req]
  }

instance WidgetEvent e => CmbOnBlur (TextAreaCfg s e) e Path where
  onBlur fn = def {
    _tacOnBlurReq = [RaiseEvent . fn]
  }

instance CmbOnBlurReq (TextAreaCfg s e) s e Path where
  onBlurReq req = def {
    _tacOnBlurReq = [req]
  }

instance WidgetEvent e => CmbOnChange (TextAreaCfg s e) Text e where
  onChange fn = def {
    _tacOnChangeReq = [RaiseEvent . fn]
  }

instance CmbOnChangeReq (TextAreaCfg s e) s e Text where
  onChangeReq req = def {
    _tacOnChangeReq = [req]
  }

data HistoryStep = HistoryStep {
  _tahText :: !Text,
  _tahCursorPos :: !(Int, Int),
  _tahSelStart :: Maybe (Int, Int)
} deriving (Eq, Show, Generic)

data TextAreaState = TextAreaState {
  _tasText :: Text,
  _tasTextMetrics :: TextMetrics,
  _tasTextStyle :: Maybe TextStyle,
  _tasCursorPos :: (Int, Int),
  _tasSelStart :: Maybe (Int, Int),
  _tasTextLines :: Seq TextLine,
  _tasHistory :: Seq HistoryStep,
  _tasHistoryIdx :: Int,
  _tasFocusStart :: Millisecond
} deriving (Eq, Show, Generic)

instance Default TextAreaState where
  def = TextAreaState {
    _tasText = "",
    _tasTextMetrics = def,
    _tasTextStyle = def,
    _tasCursorPos = def,
    _tasSelStart = def,
    _tasTextLines = Seq.empty,
    _tasHistory = Seq.empty,
    _tasHistoryIdx = 0,
    _tasFocusStart = 0
  }

-- | Creates a text area using the given lens.
textArea :: WidgetEvent e => ALens' s Text -> WidgetNode s e
textArea field = textArea_ field def

-- | Creates a text area using the given lens. Accepts config.
textArea_
  :: WidgetEvent e => ALens' s Text -> [TextAreaCfg s e] -> WidgetNode s e
textArea_ field configs = textAreaD_ wdata configs where
  wdata = WidgetLens field

-- | Creates a text area using the given value and 'onChange' event handler.
textAreaV :: WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e
textAreaV value handler = textAreaV_ value handler def

-- | Creates a text area using the given value and 'onChange' event handler.
--   Accepts config.
textAreaV_
  :: WidgetEvent e => Text -> (Text -> e) -> [TextAreaCfg s e] -> WidgetNode s e
textAreaV_ value handler configs = textAreaD_ wdata newConfig where
  wdata = WidgetValue value
  newConfig = onChange handler : configs

-- | Creates a text area providing a 'WidgetData' instance and config.
textAreaD_
  :: WidgetEvent e
  => WidgetData s Text
  -> [TextAreaCfg s e]
  -> WidgetNode s e
textAreaD_ wdata configs = scrollNode where
  config = mconcat configs
  widget = makeTextArea wdata config def
  node = defaultWidgetNode "textArea" widget
    & L.info . L.focusable .~ True
  scrollCfg = [scrollStyle L.textAreaStyle, scrollFwdStyle scrollFwdDefault]
  scrollNode = scroll_ scrollCfg node

makeTextArea
  :: WidgetEvent e
  => WidgetData s Text
  -> TextAreaCfg s e
  -> TextAreaState
  -> Widget s e
makeTextArea !wdata !config !state = widget where
  widget = createSingle state def {
    singleInit = init,
    singleMerge = merge,
    singleDispose = dispose,
    singleHandleEvent = handleEvent,
    singleGetSizeReq = getSizeReq,
    singleRender = render
  }

  !caretMs = fromMaybe defCaretMs (_tacCaretMs config)
  !maxLength = _tacMaxLength config
  !maxLines = _tacMaxLines config
  !editable = _tacReadOnly config /= Just True
  getModelValue !wenv = widgetDataGet (_weModel wenv) wdata
  -- State
  !currText = _tasText state
  !textLines = _tasTextLines state
  -- Helpers
  validText !state = validLen && validLines where
    text = _tasText state
    lines = _tasTextLines state
    validLen = T.length text <= fromMaybe maxBound maxLength
    validLines = length lines <= fromMaybe maxBound maxLines
  line !idx
    | idx >= 0 && idx < length textLines = Seq.index textLines idx ^. L.text
    | otherwise = ""
  !lineLen = T.length . line
  !totalLines = length textLines
  !lastPos = (lineLen (totalLines - 1), totalLines)

  init wenv node = resultNode newNode where
    text = getModelValue wenv
    newState = stateFromText wenv node state text
    newNode = node
      & L.widget .~ makeTextArea wdata config newState

  merge wenv node oldNode oldState = resultNode newNode where
    oldText = _tasText oldState
    newText = getModelValue wenv
    newState
      | oldText /= newText = stateFromText wenv node state newText
      | otherwise = oldState
    newNode = node
      & L.widget .~ makeTextArea wdata config newState

  dispose wenv node = resultReqs node reqs where
    widgetId = node ^. L.info . L.widgetId
    reqs = [RenderStop widgetId]

  handleKeyPress wenv mod code
    | isDelBackWordNoSel && editable = Just removeWordL
    | isDelBackWord && editable = Just (replaceText state selStart "")
    | isBackspace && emptySel && editable = Just removeCharL
    | isBackspace && editable = Just (replaceText state selStart "")
    | isMoveLeft = Just $ moveCursor txt (tpX - 1, tpY) Nothing
    | isMoveRight = Just $ moveCursor txt (tpX + 1, tpY) Nothing
    | isMoveUp = Just $ moveCursor txt (tpX, tpY - 1) Nothing
    | isMoveDown = Just $ moveCursor txt (tpX, tpY + 1) Nothing
    | isMovePageUp = Just $ moveCursor txt (tpX, tpY - vpLines) Nothing
    | isMovePageDown = Just $ moveCursor txt (tpX, tpY + vpLines) Nothing
    | isMoveWordL = Just $ moveCursor txt prevWordPos Nothing
    | isMoveWordR = Just $ moveCursor txt nextWordPos Nothing
    | isMoveLineL = Just $ moveCursor txt (0, tpY) Nothing
    | isMoveLineR = Just $ moveCursor txt (lineLen tpY, tpY) Nothing
    | isMoveFullUp = Just $ moveCursor txt (0, 0) Nothing
    | isMoveFullDn = Just $ moveCursor txt lastPos Nothing
    | isSelectAll = Just $ moveCursor txt (0, 0) (Just lastPos)
    | isSelectLeft = Just $ moveCursor txt (tpX - 1, tpY) (Just tp)
    | isSelectRight = Just $ moveCursor txt (tpX + 1, tpY) (Just tp)
    | isSelectUp = Just $ moveCursor txt (tpX, tpY - 1) (Just tp)
    | isSelectDown = Just $ moveCursor txt (tpX, tpY + 1) (Just tp)
    | isSelectPageUp = Just $ moveCursor txt (tpX, tpY - vpLines) (Just tp)
    | isSelectPageDown = Just $ moveCursor txt (tpX, tpY + vpLines) (Just tp)
    | isSelectWordL = Just $ moveCursor txt prevWordPos (Just tp)
    | isSelectWordR = Just $ moveCursor txt nextWordPos (Just tp)
    | isSelectLineL = Just $ moveCursor txt (0, tpY) (Just tp)
    | isSelectLineR = Just $ moveCursor txt (lineLen tpY, tpY) (Just tp)
    | isSelectFullUp = Just $ moveCursor txt (0, 0) (Just tp)
    | isSelectFullDn = Just $ moveCursor txt lastPos (Just tp)
    | isDeselectLeft = Just $ moveCursor txt minTpSel Nothing
    | isDeselectRight = Just $ moveCursor txt maxTpSel Nothing
    | isDeselectUp = Just $ moveCursor txt minTpSel Nothing
    | isDeselectDown = Just $ moveCursor txt maxTpSel Nothing
    | otherwise = Nothing
    where
      txt = currText
      txtLen = T.length txt
      textMetrics = _tasTextMetrics state
      tp@(tpX, tpY) = _tasCursorPos state
      selStart = _tasSelStart state

      (minTpSel, maxTpSel)
        | swap tp <= swap (fromJust selStart) = (tp, fromJust selStart)
        | otherwise = (fromJust selStart, tp)
      emptySel = isNothing selStart
      vpLines = round (wenv ^. L.viewport . L.h / textMetrics ^. L.lineH)
      activeSel = isJust selStart

      prevTxt
        | tpX > 0 = T.take tpX (line tpY)
        | otherwise = line (tpY - 1)
      prevWordStart = T.dropWhileEnd (not . delim) . T.dropWhileEnd delim $ prevTxt
      prevWordPos
        | tpX == 0 && tpY == 0 = (tpX, tpY)
        | tpX > 0 = (T.length prevWordStart, tpY)
        | otherwise = (T.length prevWordStart, tpY - 1)

      nextTxt
        | tpX < lineLen tpY = T.drop tpX (line tpY)
        | otherwise = line (tpY + 1)
      nextWordEnd = T.dropWhile (not . delim) . T.dropWhile delim $ nextTxt
      nextWordPos
        | tpX == lineLen tpY && tpY == length textLines - 1 = (tpX, tpY)
        | tpX < lineLen tpY = (lineLen tpY - T.length nextWordEnd, tpY)
        | otherwise = (lineLen (tpY + 1) - T.length nextWordEnd, tpY + 1)

      isShift = _kmLeftShift mod
      isLeft = isKeyLeft code
      isRight = isKeyRight code
      isUp = isKeyUp code
      isDown = isKeyDown code
      isHome = isKeyHome code
      isEnd = isKeyEnd code
      isPageUp = isKeyPageUp code
      isPageDown = isKeyPageDown code

      isWordMod
        | isMacOS wenv = _kmLeftAlt mod
        | otherwise = _kmLeftCtrl mod
      isLineMod
        | isMacOS wenv = _kmLeftCtrl mod || _kmLeftGUI mod
        | otherwise = _kmLeftAlt mod
      isAllMod
        | isMacOS wenv = _kmLeftGUI mod
        | otherwise = _kmLeftCtrl mod

      isBackspace = isKeyBackspace code
      isDelBackWord = isBackspace && isWordMod
      isDelBackWordNoSel = isDelBackWord && emptySel

      isMove = not isShift && not isWordMod && not isLineMod
      isMoveWord = not isShift && isWordMod && not isLineMod
      isMoveLine = not isShift && isLineMod && not isWordMod

      isSelect = isShift && not isWordMod && not isLineMod
      isSelectWord = isShift && isWordMod && not isLineMod
      isSelectLine = isShift && isLineMod && not isWordMod

      isMoveLeft = isMove && not activeSel && isLeft
      isMoveRight = isMove && not activeSel && isRight
      isMoveWordL = isMoveWord && isLeft
      isMoveWordR = isMoveWord && isRight
      isMoveLineL = (isMoveLine && isLeft) || (not isShift && isHome)
      isMoveLineR = (isMoveLine && isRight) || (not isShift && isEnd)
      isMoveFullUp = isMoveLine && isUp
      isMoveFullDn = isMoveLine && isDown
      isMoveUp = isMove && not activeSel && isUp
      isMoveDown = isMove && not activeSel && isDown
      isMovePageUp = isMove && not activeSel && isPageUp
      isMovePageDown = isMove && not activeSel && isPageDown

      isSelectAll = isAllMod && isKeyA code
      isSelectLeft = isSelect && isLeft
      isSelectRight = isSelect && isRight
      isSelectUp = isSelect && isUp
      isSelectDown = isSelect && isDown
      isSelectPageUp = isSelect && isPageUp
      isSelectPageDown = isSelect && isPageDown
      isSelectWordL = isSelectWord && isLeft
      isSelectWordR = isSelectWord && isRight
      isSelectLineL = (isSelectLine && isLeft) || (isShift && isHome)
      isSelectLineR = (isSelectLine && isRight) || (isShift && isEnd)
      isSelectFullUp = isSelectLine && isUp
      isSelectFullDn = isSelectLine && isDown

      isDeselectLeft = isMove && activeSel && isLeft
      isDeselectRight = isMove && activeSel && isRight
      isDeselectUp = isMove && activeSel && isUp
      isDeselectDown = isMove && activeSel && isDown

      replaceFix sel text = replaceText state (Just $ fixPos sel) text
      removeCharL
        | tpX > 0 = replaceFix (tpX - 1, tpY) ""
        | otherwise = replaceFix (lineLen (tpY - 1), tpY - 1) ""
      removeWordL = replaceFix prevWordPos ""
      moveCursor txt newPos newSel
        | isJust selStart && isNothing newSel = (txt, fixedPos, Nothing)
        | isJust selStart && Just fixedPos == selStart = (txt, fixedPos, Nothing)
        | isJust selStart = (txt, fixedPos, selStart)
        | Just fixedPos == fixedSel = (txt, fixedPos, Nothing)
        | otherwise = (txt, fixedPos, fixedSel)
        where
          fixedPos = fixPos newPos
          fixedSel = fmap fixPos newSel
      fixPos (cX, cY) = result where
        nlines = length textLines
        vcY = clamp 0 (nlines - 1) cY
        vcX = clamp 0 (lineLen tpY) cX
        ncX = clamp 0 (lineLen vcY) cX
        sameX = vcX == tpX
        sameY = vcY == tpY
        result
          | sameY && cX < 0 && vcY == 0 = (0, 0)
          | sameY && cX < 0 && vcY > 0 = (lineLen (vcY - 1) + cX + 1, vcY - 1)
          | sameY && cX > lineLen vcY && vcY < nlines - 1 = (cX - lineLen vcY - 1, vcY + 1)
          | sameX && cX > lineLen vcY = (min cX (lineLen vcY), vcY)
          | otherwise = (ncX, vcY)

  handleEvent wenv node target evt = case evt of
    ButtonAction point btn BtnPressed clicks
      | clicks == 1 -> Just result where
        newPos = findClosestGlyphPos state (localPoint point)
        newState = state {
          _tasCursorPos = newPos,
          _tasSelStart = Nothing
        }
        newNode = node
          & L.widget .~ makeTextArea wdata config newState
        result = resultReqs newNode [RenderOnce]

    -- Select word if clicked twice in a row
    ButtonAction point btn BtnReleased clicks
      | clicks == 2 -> result where
        (tx, ty) = findClosestGlyphPos state (localPoint point)
        currText = Seq.index textLines ty ^. L.text
        (part1, part2) = T.splitAt tx currText
        txtLen = T.length currText
        wordStart = T.dropWhileEnd (not . delim) part1
        wordStartIdx = T.length wordStart
        wordEnd = T.dropWhile (not . delim) part2
        wordEndIdx = txtLen - T.length wordEnd
        newPos = (wordStartIdx, ty)
        newSel = Just (wordEndIdx, ty)
        newState = state {
          _tasCursorPos = newPos,
          _tasSelStart = newSel
        }
        newNode = node
          & L.widget .~ makeTextArea wdata config newState
        result
          | ty < totalLines = Just (resultReqs newNode [RenderOnce])
          | otherwise = Nothing

    -- Select line if clicked three times in a row
    ButtonAction point btn BtnReleased clicks
      | clicks == 3 -> result where
        (tx, ty) = findClosestGlyphPos state (localPoint point)
        glyphs = Seq.index textLines ty ^. L.glyphs
        newPos = (0, ty)
        newSel = Just (length glyphs, ty)
        newState = state {
          _tasCursorPos = newPos,
          _tasSelStart = newSel
        }
        newNode = node
          & L.widget .~ makeTextArea wdata config newState
        result
          | ty < totalLines = Just (resultReqs newNode [RenderOnce])
          | otherwise = Nothing

    -- Select all if clicked four times in a row
    ButtonAction point btn BtnReleased clicks
      | clicks == 4 -> result where
        glyphs = Seq.index textLines (totalLines - 1) ^. L.glyphs
        newPos = (0, 0)
        newSel = Just (length glyphs, totalLines - 1)
        newState = state {
          _tasCursorPos = newPos,
          _tasSelStart = newSel
        }
        newNode = node
          & L.widget .~ makeTextArea wdata config newState
        result
          | totalLines > 0 = Just (resultReqs newNode [RenderOnce])
          | otherwise = Nothing

    Move point
      | isNodePressed wenv node -> Just result where
        curPos = _tasCursorPos state
        selStart = _tasSelStart state
        newPos = findClosestGlyphPos state (localPoint point)
        newSel = selStart <|> Just curPos
        newState = state {
          _tasCursorPos = newPos,
          _tasSelStart = newSel
        }
        scrollReq = generateScrollReq wenv node newState
        newNode = node
          & L.widget .~ makeTextArea wdata config newState
        result = resultReqs newNode (RenderOnce : scrollReq)

    KeyAction mod code KeyPressed
      | isKeyboardCopy wenv evt -> Just resultCopy
      | isKeyboardPaste wenv evt && editable -> Just resultPaste
      | isKeyboardCut wenv evt && editable -> Just resultCut
      | isKeyboardUndo wenv evt && editable -> Just $ moveHistory bwdState (-1)
      | isKeyboardRedo wenv evt && editable -> Just $ moveHistory state 1
      | isKeyReturn code && editable -> Just resultReturn
      | isKeyTab code && acceptTab && editable -> Just resultTab
      | otherwise -> fmap handleKeyRes (handleKeyPress wenv mod code)
      where
        acceptTab = fromMaybe False (_tacAcceptTab config)
        selectedText = fromMaybe "" (getSelection state)
        clipboardReq = SetClipboard (ClipboardText selectedText)

        resultCopy = resultReqs node [clipboardReq]
        resultPaste = resultReqs node [GetClipboard widgetId]
        resultCut = insertText wenv node ""
          & L.requests <>~ Seq.singleton clipboardReq
        resultReturn = insertText wenv node "\n"
        resultTab = insertText wenv node "    "
          & L.requests <>~ Seq.singleton IgnoreParentEvents

        history = _tasHistory state
        historyIdx = _tasHistoryIdx state

        bwdState = addHistory state (historyIdx == length history)

        moveHistory state steps = result where
          newIdx = clamp 0 (length history) (historyIdx + steps)
          newState = restoreHistory wenv node state newIdx
          newNode = node
            & L.widget .~ makeTextArea wdata config newState
          result = resultReqs newNode (generateReqs wenv node newState)

        handleKeyRes (newText, newPos, newSel) = result where
          tmpState = addHistory state (_tasText state /= newText)
          newState = (stateFromText wenv node tmpState newText) {
            _tasCursorPos = newPos,
            _tasSelStart = newSel
          }
          newNode = node
            & L.widget .~ makeTextArea wdata config newState
          result = resultReqs newNode (generateReqs wenv node newState)

    TextInput newText
      | editable -> Just result where
        result = insertText wenv node newText

    Clipboard (ClipboardText newText) -> Just result where
      result = insertText wenv node newText

    Focus prev -> Just result where
      selectOnFocus = fromMaybe False (_tacSelectOnFocus config)
      tmpState
        | selectOnFocus && T.length currText > 0 = state {
            _tasCursorPos = lastPos,
            _tasSelStart = Just (0, 0)
          }
        | otherwise = state
      newState = tmpState {
        _tasFocusStart = wenv ^. L.timestamp
      }
      reqs = [RenderEvery widgetId caretMs Nothing, StartTextInput viewport]
      newNode = node
        & L.widget .~ makeTextArea wdata config newState
      newResult = resultReqs newNode reqs
      focusRs = handleFocusChange newNode prev (_tacOnFocusReq config)
      result = maybe newResult (newResult <>) focusRs

    Blur next -> Just result where
      reqs = [RenderStop widgetId, StopTextInput]
      newResult = resultReqs node reqs
      blurRes = handleFocusChange node next (_tacOnBlurReq config)
      result = maybe newResult (newResult <>) blurRes
    _ -> Nothing

    where
      widgetId = node ^. L.info . L.widgetId
      viewport = node ^. L.info . L.viewport
      style = currentStyle wenv node
      Rect cx cy cw ch = getContentArea node style
      localPoint point = subPoint point (Point cx cy)

  insertText wenv node addedText = result where
    currSel = _tasSelStart state
    (newText, newPos, newSel) = replaceText state currSel addedText
    tmpState = addHistory state (_tasText state /= newText)
    newState = (stateFromText wenv node tmpState newText) {
      _tasCursorPos = newPos,
      _tasSelStart = newSel
    }
    newNode = node
      & L.widget .~ makeTextArea wdata config newState
    newReqs = generateReqs wenv node newState
    result
      | validText newState = resultReqs newNode newReqs
      | otherwise = resultNode node

  generateReqs wenv node newState = reqs ++ reqScroll where
    widgetId = node ^. L.info . L.widgetId
    oldText = _tasText state
    newText = _tasText newState
    reqUpdate = widgetDataSet wdata newText
    reqOnChange = fmap ($ newText) (_tacOnChangeReq config)
    reqResize = [ResizeWidgetsImmediate widgetId]
    reqScroll = generateScrollReq wenv node newState
    reqs
      | oldText /= newText = reqUpdate ++ reqOnChange ++ reqResize
      | otherwise = []

  generateScrollReq wenv node newState = scrollReq where
    style = currentStyle wenv node
    scPath = parentPath node
    scWid = widgetIdFromPath wenv scPath
    contentArea = getContentArea node style
    offset = Point (contentArea ^. L.x) (contentArea ^. L.y)
    caretRect = getCaretRect config newState
    -- Padding/border added to show left/top borders when moving near them
    scrollRect = fromMaybe caretRect (addOuterBounds style caretRect)
    scrollMsg = ScrollTo $ moveRect offset scrollRect
    scrollReq
      | rectInRect caretRect (wenv ^. L.viewport) || isNothing scWid = []
      | otherwise = [SendMessage (fromJust scWid) scrollMsg]

  getSizeReq wenv node = sizeReq where
    Size w h = getTextLinesSize textLines
    {- getTextLines does not return the vertical spacing for the last line, but
    we need it since the selection rect displays it. -}
    spaceV = getSpaceV textLines
    sizeReq = (minWidth (max 100 w), minHeight (max 20 (h + spaceV)))

  render wenv node renderer =
    drawInTranslation renderer offset $ do
      when selRequired $
        forM_ selRects $ \rect ->
          when (rect ^. L.w > 0) $
            drawRect renderer rect (Just selColor) Nothing

      forM_ textLines (drawTextLine renderer style)

      when caretRequired $
        drawRect renderer caretRect (Just caretColor) Nothing
    where
      style = currentStyle wenv node
      contentArea = getContentArea node style
      ts = _weTimestamp wenv
      offset = Point (contentArea ^. L.x) (contentArea ^. L.y)
      focused = isNodeFocused wenv node

      caretTs = ts - _tasFocusStart state
      caretRequired = focused && even (caretTs `div` caretMs)
      caretColor = styleFontColor style
      caretRect = getCaretRect config state

      selRequired = isJust (_tasSelStart state)
      selColor = styleHlColor style
      selRects = getSelectionRects state contentArea

getCaretRect :: TextAreaCfg s e -> TextAreaState -> Rect
getCaretRect config state = caretRect where
  (cursorX, cursorY) = _tasCursorPos state
  Rect tx ty _ _ = lineRect
  TextMetrics asc desc lineh _ = _tasTextMetrics state
  textLines = _tasTextLines state

  (lineRect, glyphs, fspaceV) = case Seq.lookup cursorY textLines of
    Just tl -> (tl ^. L.rect, tl ^. L.glyphs, tl ^. L.fontSpaceV)
    Nothing -> (def, Seq.empty, def)
  spaceV = unFontSpace fspaceV

  caretPos
    | cursorX == 0 || cursorX > length glyphs = 0
    | cursorX == length glyphs = _glpXMax (Seq.index glyphs (cursorX - 1))
    | otherwise = _glpXMin (Seq.index glyphs cursorX)

  caretX = max 0 (tx + caretPos)
  caretY = ty - spaceV
  caretW = fromMaybe defCaretW (_tacCaretWidth config)
  caretH = lineh + spaceV

  caretRect = Rect caretX caretY caretW caretH

getSelectionRects :: TextAreaState -> Rect -> [Rect]
getSelectionRects state contentArea = rects where
  currPos = _tasCursorPos state
  currSel = fromMaybe def (_tasSelStart state)
  TextMetrics asc desc lineh _ = _tasTextMetrics state
  textLines = _tasTextLines state

  spaceV = getSpaceV textLines
  line idx
    | length textLines > idx = Seq.index textLines idx ^. L.text
    | otherwise = ""
  lineLen = T.length . line

  glyphs idx
    | length textLines > idx = Seq.index textLines idx ^. L.glyphs
    | otherwise = Seq.empty
  glyphPos posx posy
    | posx == 0 = 0
    | posx == lineLen posy = _glpXMax (Seq.index (glyphs posy) (posx - 1))
    | otherwise = _glpXMin (Seq.index (glyphs posy) posx)

  ((selX1, selY1), (selX2, selY2))
    | swap currPos <= swap currSel = (currPos, currSel)
    | otherwise = (currSel, currPos)

  totalH = lineh + spaceV
  updateRect rect = rect
    & L.y -~ spaceV
    & L.h .~ totalH
    & L.w %~ max 5 -- Empty lines show a small rect to indicate they are there.
  makeRect cx1 cx2 cy = Rect rx ry rw rh where
    rx = glyphPos cx1 cy
    rw = glyphPos cx2 cy - rx
    ry = fromIntegral cy * totalH - spaceV
    rh = totalH
  rects
    | selY1 == selY2 = [makeRect selX1 selX2 selY1]
    | otherwise = begin : middle ++ end where
      begin = makeRect selX1 (lineLen selY1) selY1
      middleLines = Seq.drop (selY1 + 1) . Seq.take selY2 $ textLines
      middle = toList (updateRect . view L.rect <$> middleLines)
      end = [makeRect 0 selX2 selY2]

stateFromText
  :: WidgetEnv s e -> WidgetNode s e -> TextAreaState -> Text -> TextAreaState
stateFromText wenv node state text = newState where
  style = currentStyle wenv node
  fontMgr = wenv ^. L.fontManager
  newTextMetrics = getTextMetrics wenv style
  tmpTextLines = fitTextToWidth fontMgr style maxNumericValue KeepSpaces text
  totalH = newTextMetrics ^. L.lineH + getSpaceV tmpTextLines
  lastRect = def
    & L.y .~ fromIntegral (length tmpTextLines) * totalH
    & L.h .~ totalH

  lastTextLine = def
    & L.rect .~ lastRect
    & L.size .~ Size 0 (lastRect ^. L.h)
  newTextLines
    | T.isSuffixOf "\n" text = tmpTextLines |> lastTextLine
    | otherwise = tmpTextLines

  newState = state {
    _tasText = text,
    _tasTextMetrics = newTextMetrics,
    _tasTextStyle = style ^. L.text,
    _tasTextLines = newTextLines
  }

textFromState :: Seq TextLine -> Text
textFromState textLines = T.unlines lines where
  lines = toList (view L.text <$> textLines)

addHistory :: TextAreaState -> Bool -> TextAreaState
addHistory state False = state
addHistory state _ = newState where
  text = _tasText state
  curPos = _tasCursorPos state
  selStart = _tasSelStart state
  prevStepIdx = _tasHistoryIdx state
  prevSteps = _tasHistory state
  steps = Seq.take prevStepIdx prevSteps
  newState = state {
    _tasHistory = steps |> HistoryStep text curPos selStart,
    _tasHistoryIdx = prevStepIdx + 1
  }

restoreHistory
  :: WidgetEnv s e -> WidgetNode s e -> TextAreaState -> Int -> TextAreaState
restoreHistory wenv node state idx
  | idx >= 0 && idx < length hist && idx /= histIdx = newState
  | otherwise = state
  where
    hist = _tasHistory state
    histIdx = _tasHistoryIdx state
    HistoryStep text curPos selStart = Seq.index hist idx
    tmpState = stateFromText wenv node state text
    newState = tmpState {
      _tasCursorPos = curPos,
      _tasSelStart = selStart,
      _tasHistoryIdx = idx
    }

getSelection
  :: TextAreaState
  -> Maybe Text
getSelection state = result where
  currPos = _tasCursorPos state
  currSel = fromJust (_tasSelStart state)
  textLines = _tasTextLines state
  oldLines = view L.text <$> textLines

  ((selX1, selY1), (selX2, selY2))
    | swap currPos <= swap currSel = (currPos, currSel)
    | otherwise = (currSel, currPos)
  newText
    | selY1 == selY2 = singleLine
    | selX2 == 0 = T.unlines . toList $ begin :<| middle
    | otherwise = T.unlines . toList $ begin :<| (middle :|> end)
    where
      singleLine = T.drop selX1 $ T.take selX2 (Seq.index oldLines selY1)
      begin = T.drop selX1 $ Seq.index oldLines selY1
      middle = Seq.drop (selY1 + 1) $ Seq.take selY2 oldLines
      end = T.take selX2 $ Seq.index oldLines selY2
  result
    | isJust (_tasSelStart state) = Just newText
    | otherwise = Nothing

replaceText
  :: TextAreaState
  -> Maybe (Int, Int)
  -> Text
  -> (Text, (Int, Int), Maybe (Int, Int))
replaceText state currSel newTxt
  | isJust currSel = replaceSelection lines currPos (fromJust currSel) newTxt
  | otherwise = replaceSelection lines currPos currPos newTxt
  where
    currPos = _tasCursorPos state
    lines = _tasTextLines state

replaceSelection
  :: Seq TextLine
  -> (Int, Int)
  -> (Int, Int)
  -> Text
  -> (Text, (Int, Int), Maybe (Int, Int))
replaceSelection textLines currPos currSel addText = result where
  oldLines = view L.text <$> textLines
  ((selX1, selY1), (selX2, selY2))
    | swap currPos <= swap currSel = (currPos, currSel)
    | otherwise = (currSel, currPos)
  prevLines = Seq.take selY1 oldLines
  postLines = Seq.drop (selY2 + 1) oldLines
  returnAdded = T.isSuffixOf "\n" addText

  linePre
    | length oldLines > selY1 = T.take selX1 (Seq.index oldLines selY1)
    | otherwise = ""
  lineSuf
    | length oldLines > selY2 = T.drop selX2 (Seq.index oldLines selY2)
    | otherwise = ""
  addLines
    | not returnAdded = Seq.fromList (T.lines addText)
    | otherwise = Seq.fromList (T.lines addText) :|> ""

  (newX, newY, midLines)
    | length addLines <= 1 = (T.length (linePre <> addText), selY1, singleLine)
    | otherwise = (T.length end, selY1 + length addLines - 1, multiline)
    where
      singleLine = Seq.singleton $ linePre <> addText <> lineSuf
      begin = Seq.index addLines 0
      middle = Seq.drop 1 $ Seq.take (length addLines - 1) addLines
      end = Seq.index addLines (length addLines - 1)
      multiline = (linePre <> begin) :<| (middle :|> (end <> lineSuf))

  newLines = prevLines <> midLines <> postLines
  newText = T.dropEnd 1 $ T.unlines (toList newLines)
  result = (newText, (newX, newY), Nothing)

findClosestGlyphPos :: TextAreaState -> Point -> (Int, Int)
findClosestGlyphPos state point = (newPos, lineIdx) where
  Point x y = point
  TextMetrics _ _ lineh _ = _tasTextMetrics state
  textLines = _tasTextLines state

  totalH = lineh + getSpaceV textLines
  lineIdx = clamp 0 (length textLines - 1) (floor (y / totalH))
  lineGlyphs
    | null textLines = Seq.empty
    | otherwise = Seq.index (view L.glyphs <$> textLines) lineIdx
  textLen = getGlyphsMax lineGlyphs

  glyphs
    | Seq.null lineGlyphs = Seq.empty
    | otherwise = lineGlyphs |> GlyphPos ' ' 0 textLen 0 0 0 0 0
  glyphStart i g = (i, abs (_glpXMin g - x))

  pairs = Seq.mapWithIndex glyphStart glyphs
  cpm (_, g1) (_, g2) = compare g1 g2
  diffs = Seq.sortBy cpm pairs
  newPos = maybe 0 fst (Seq.lookup 0 diffs)

getSpaceV :: Seq TextLine -> Double
getSpaceV textLines = spaceV where
  spaceV = unFontSpace $ maybe def (view L.fontSpaceV) (textLines ^? ix 0)

delim :: Char -> Bool
delim c = c `elem` [' ', '.', ',', '/', '-', ':']