From 4d50b9fc61e0f32278c8e6171090e3677b42b502 Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Wed, 19 May 2021 23:49:15 -0300 Subject: [PATCH] Add selection basics to textArea --- src/Monomer/Core/ThemeTypes.hs | 3 ++ src/Monomer/Core/Themes/BaseTheme.hs | 6 +++ src/Monomer/Widgets/Singles/TextArea.hs | 70 +++++++++++++++++++++---- tasks.md | 1 + 4 files changed, 70 insertions(+), 10 deletions(-) diff --git a/src/Monomer/Core/ThemeTypes.hs b/src/Monomer/Core/ThemeTypes.hs index 6406b0f7..357121f9 100644 --- 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 } diff --git a/src/Monomer/Core/Themes/BaseTheme.hs b/src/Monomer/Core/Themes/BaseTheme.hs index 9f1648f7..2f684145 100644 --- 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 diff --git a/src/Monomer/Widgets/Singles/TextArea.hs b/src/Monomer/Widgets/Singles/TextArea.hs index 40701e81..ee0e7483 100644 --- 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 diff --git a/tasks.md b/tasks.md index 4c4d7921..3135f286 100644 --- 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