mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-20 16:27:49 +03:00
Add selection basics to textArea
This commit is contained in:
parent
0c05c6b03e
commit
4d50b9fc61
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user