Add selection basics to textArea

2024-09-20 16:27:49 +03:00 · 2021-05-19 23:49:15 -03:00 · 2021-05-19 23:49:15 -03:00 · 4d50b9fc61
commit 4d50b9fc61
parent 0c05c6b03e
4 changed files with 70 additions and 10 deletions
--- a/src/Monomer/Core/ThemeTypes.hs
+++ b/src/Monomer/Core/ThemeTypes.hs
@ -78,6 +78,7 @@ data ThemeState = ThemeState {
  _thsSliderThumbFactor :: Double,
  _thsSliderWheelRate :: Rational,
  _thsSliderWidth :: Double,
+  _thsTextAreaStyle :: StyleState,
  _thsTooltipStyle :: StyleState,
  _thsUserStyleMap :: M.Map String StyleState
 } deriving (Eq, Show, Generic)
@ -127,6 +128,7 @@ instance Default ThemeState where
    _thsSliderThumbFactor = 1.25,
    _thsSliderWheelRate = 10,
    _thsSliderWidth = 10,
+    _thsTextAreaStyle = def,
    _thsTooltipStyle = def,
    _thsUserStyleMap = M.empty
  }
@ -176,6 +178,7 @@ instance Semigroup ThemeState where
    _thsSliderWheelRate = _thsSliderWheelRate t2,
    _thsSliderWidth = _thsSliderWidth t2,
    _thsSliderRadius = _thsSliderRadius t2 <|> _thsSliderRadius t1,
+    _thsTextAreaStyle = _thsTextAreaStyle t1 <> _thsTextAreaStyle t2,
    _thsTooltipStyle = _thsTooltipStyle t1 <> _thsTooltipStyle t2,
    _thsUserStyleMap = _thsUserStyleMap t1 <> _thsUserStyleMap t2
  }
--- a/src/Monomer/Core/Themes/BaseTheme.hs
+++ b/src/Monomer/Core/Themes/BaseTheme.hs
@ -204,6 +204,7 @@ baseBasic themeMod = def
  & L.sliderStyle . L.fgColor ?~ inputFgBasic themeMod
  & L.sliderStyle . L.hlColor ?~ inputHlBasic themeMod
  & L.sliderStyle . L.sndColor ?~ inputSndBasic themeMod
+  & L.textAreaStyle .~ inputStyle themeMod
  & L.tooltipStyle . L.text ?~ (smallFont & L.fontColor ?~ tooltipText themeMod)
  & L.tooltipStyle . L.bgColor ?~ tooltipBg themeMod
  & L.tooltipStyle . L.border ?~ border 1 (tooltipBorder themeMod)
@ -249,6 +250,7 @@ baseHover themeMod = baseBasic themeMod
  & L.sliderStyle . L.hlColor ?~ inputHlHover themeMod
  & L.sliderStyle . L.sndColor ?~ inputSndHover themeMod
  & L.sliderStyle . L.cursorIcon ?~ CursorHand
+  & L.textAreaStyle . L.cursorIcon ?~ CursorIBeam

 baseFocus :: BaseThemeColors -> ThemeState
 baseFocus themeMod = baseBasic themeMod
@ -272,6 +274,8 @@ baseFocus themeMod = baseBasic themeMod
  & L.sliderStyle . L.fgColor ?~ inputFgFocus themeMod
  & L.sliderStyle . L.hlColor ?~ inputHlFocus themeMod
  & L.sliderStyle . L.sndColor ?~ inputSndFocus themeMod
+  & L.textAreaStyle . L.border ?~ borderFocus themeMod
+  & L.textAreaStyle . L.hlColor ?~ inputSelFocus themeMod

 baseFocusHover :: BaseThemeColors -> ThemeState
 baseFocusHover themeMod = (baseHover themeMod <> baseFocus themeMod)
@ -298,6 +302,8 @@ baseActive themeMod = baseFocusHover themeMod
  & L.sliderStyle . L.fgColor ?~ inputFgActive themeMod
  & L.sliderStyle . L.hlColor ?~ inputHlActive themeMod
  & L.sliderStyle . L.sndColor ?~ inputSndActive themeMod
+  & L.textAreaStyle . L.border ?~ borderFocus themeMod
+  & L.textAreaStyle . L.hlColor ?~ inputSelFocus themeMod

 baseDisabled :: BaseThemeColors -> ThemeState
 baseDisabled themeMod = baseBasic themeMod
--- a/src/Monomer/Widgets/Singles/TextArea.hs
+++ b/src/Monomer/Widgets/Singles/TextArea.hs
@ -95,6 +95,7 @@ textArea_ field configs = node where
 makeTextArea :: WidgetData s Text -> TextAreaCfg -> TextAreaState -> Widget s e
 makeTextArea wdata config state = widget where
  widget = createSingle state def {
+    singleGetBaseStyle = getBaseStyle,
    singleInit = init,
    singleDispose = dispose,
    singleHandleEvent = handleEvent,
@ -109,6 +110,9 @@ makeTextArea wdata config state = widget where
  currText = _tasText state
  textLines = _tasTextLines state

+  getBaseStyle wenv node = Just style where
+    style = collectTheme wenv L.textAreaStyle
+
  init wenv node = resultWidget newNode where
    text = getModelValue wenv
    newState = stateFromText wenv node state text
@ -132,26 +136,30 @@ makeTextArea wdata config state = widget where
    | isMoveWordR = Just $ moveCursor txt nextWordPos Nothing
    | isMoveLineL = Just $ moveCursor txt (0, tpY) Nothing
    | isMoveLineR = Just $ moveCursor txt (lineLen tpY, tpY) Nothing
--    | isSelectAll = Just $ moveCursor txt 0 (Just txtLen)
--    | isSelectLeft = Just $ moveCursor txt (tp - 1) (Just tp)
--    | isSelectRight = Just $ moveCursor txt (tp + 1) (Just tp)
--    | isSelectWordL = Just $ moveCursor txt prevWordStartIdx (Just tp)
--    | isSelectWordR = Just $ moveCursor txt nextWordEndIdx (Just tp)
+    | isSelectAll = Just $ moveCursor txt (0, 0) (Just (totalLines, lineLen (totalLines - 1)))
+    | isSelectLeft = Just $ moveCursor txt (tpX - 1, tpY) (Just tp)
+    | isSelectRight = Just $ moveCursor txt (tpX + 1, tpY) (Just tp)
+    | isSelectWordL = Just $ moveCursor txt prevWordPos (Just tp)
+    | isSelectWordR = Just $ moveCursor txt nextWordPos (Just tp)
 --    | isSelectLineL = Just $ moveCursor txt 0 (Just tp)
 --    | isSelectLineR = Just $ moveCursor txt txtLen (Just tp)
--    | isDeselectLeft = Just $ moveCursor txt minTpSel Nothing
--    | isDeselectRight = Just $ moveCursor txt maxTpSel Nothing
+    | isDeselectLeft = Just $ moveCursor txt minTpSel Nothing
+    | isDeselectRight = Just $ moveCursor txt maxTpSel Nothing
    | otherwise = Nothing
    where
      txt = currText
      txtLen = T.length txt
-      (tpX, tpY) = _tasCursorPos 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
      line idx
        | length textLines > idx = Seq.index textLines idx ^. L.text
        | otherwise = ""
      lineLen = T.length . line
+      totalLines = length textLines
      --(part1, part2) = T.splitAt currPos currText
      --currSelVal = fromMaybe 0 selStart
      activeSel = isJust selStart
@ -289,6 +297,10 @@ makeTextArea wdata config state = widget where
    sizeReq = (minWidth 100, minHeight 100)

  render wenv node renderer = do
+    when selRequired $
+      forM_ selRects $ \rect ->
+        drawRect renderer rect (Just selColor) Nothing
+
    forM_ textLines (drawTextLine renderer style)

    when caretRequired $
@ -300,12 +312,15 @@ makeTextArea wdata config state = widget where
      caretRequired = isNodeFocused wenv node && ts `mod` 1000 < 500
      caretColor = styleFontColor style
      caretRect = getCaretRect state contentArea
+      selRequired = isJust (_tasSelStart state)
+      selColor = styleHlColor style
+      selRects = getSelectionRects state contentArea

 getCaretRect :: TextAreaState -> Rect -> Rect
 getCaretRect state contentArea = caretRect where
  Rect cx cy cw ch = contentArea 
  (cursorX, cursorY) = _tasCursorPos state
-  TextMetrics _ _ lineh = _tasTextMetrics state
+  TextMetrics _ desc lineh = _tasTextMetrics state
  textLines = _tasTextLines state
  (lineRect, glyphs) = case Seq.lookup cursorY textLines of
    Just tl -> (tl ^. L.rect, tl ^. L.glyphs)
@ -316,9 +331,44 @@ getCaretRect state contentArea = caretRect where
    | cursorX == length glyphs = _glpXMax (Seq.index glyphs (cursorX - 1))
    | otherwise = _glpXMin (Seq.index glyphs cursorX)
  caretX = max 0 $ min (cx + cw - caretW) (tx + caretPos)
-  caretY = cy + ty
+  caretY = cy + ty + desc
  caretRect = Rect caretX caretY caretW lineh

+getSelectionRects :: TextAreaState -> Rect -> [Rect]
+getSelectionRects state contentArea = rects where
+  currPos = _tasCursorPos state
+  currSel = fromMaybe def (_tasSelStart state)
+  TextMetrics _ desc lineh = _tasTextMetrics state
+  textLines = _tasTextLines state
+  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)
+  makeRect cx1 cx2 cy = Rect rx ry rw rh where
+    rx = glyphPos cx1 cy
+    rw = glyphPos cx2 cy - rx
+    ry = fromIntegral cy * lineh
+    rh = lineh
+  pairs
+    | selY1 == selY2 = [makeRect selX1 selX2 selY1]
+    | otherwise = begin : middle ++ end where
+      begin = makeRect selX1 (lineLen selY1) selY1
+      middleLines = Seq.drop selY1 . Seq.take (selY2 - selY2) $ textLines
+      middle = toList (view L.rect <$> textLines)
+      end = [makeRect 0 selX2 selY2]
+  offset = Point (contentArea ^. L.x) (contentArea ^. L.y + desc)
+  rects = moveRect offset <$> pairs
+
 stateFromText
  :: WidgetEnv s e -> WidgetNode s e -> TextAreaState -> Text -> TextAreaState
 stateFromText wenv node state text = newState where
--- a/tasks.md
+++ b/tasks.md
@ -626,6 +626,7 @@
 Next
  - Create ContextMenu (could work similarly to Tooltip)
  - Add support for multiline text editing
+    - Rename _thsInputNumericStyle

 Future
  - Check cross compilation