From e698cd6d707bb4c5df6c5018bdf9978693e0fc1a Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Wed, 9 Sep 2020 17:15:55 -0300 Subject: [PATCH] Add highlighted color --- src/Monomer/Common/Style.hs | 15 +++++--- src/Monomer/Common/StyleCombinators.hs | 5 ++- src/Monomer/Common/StyleUtil.hs | 32 +++------------- src/Monomer/Graphics/Drawing.hs | 2 +- src/Monomer/Widget/Util.hs | 50 ++++++++++++++++++++----- src/Monomer/Widget/Widgets/Checkbox.hs | 2 +- src/Monomer/Widget/Widgets/Radio.hs | 2 +- src/Monomer/Widget/Widgets/TextField.hs | 32 ++++++++-------- 8 files changed, 80 insertions(+), 60 deletions(-) diff --git a/src/Monomer/Common/Style.hs b/src/Monomer/Common/Style.hs index 00746373..57a53e23 100644 --- a/src/Monomer/Common/Style.hs +++ b/src/Monomer/Common/Style.hs @@ -26,17 +26,19 @@ instance Monoid Theme where data ThemeState = ThemeState { _thsFgColor :: Color, + _thsHlColor :: Color, _thsFont :: Font, _thsFontSize :: FontSize, - _thsColor :: Color + _thsFontColor :: Color } deriving (Show, Eq) instance Default ThemeState where def = ThemeState { _thsFgColor = Color 255 255 255 1, + _thsHlColor = Color 0 0 200 1, _thsFont = Font "sans", _thsFontSize = FontSize 36, - _thsColor = Color 255 255 255 1 + _thsFontColor = Color 255 255 255 1 } instance Semigroup ThemeState where @@ -78,6 +80,7 @@ data StyleState = StyleState { _sstRadius :: Maybe Radius, _sstBgColor :: Maybe Color, _sstFgColor :: Maybe Color, + _sstHlColor :: Maybe Color, _sstText :: Maybe TextStyle } deriving (Show, Eq) @@ -91,6 +94,7 @@ instance Default StyleState where _sstRadius = Nothing, _sstBgColor = Nothing, _sstFgColor = Nothing, + _sstHlColor = Nothing, _sstText = Nothing } @@ -104,6 +108,7 @@ instance Semigroup StyleState where _sstRadius = _sstRadius s1 <> _sstRadius s2, _sstBgColor = _sstBgColor s1 <> _sstBgColor s2, _sstFgColor = _sstFgColor s1 <> _sstFgColor s2, + _sstHlColor = _sstHlColor s1 <> _sstHlColor s2, _sstText = _sstText s1 <> _sstText s2 } @@ -234,7 +239,7 @@ instance Monoid Radius where data TextStyle = TextStyle { _txsFont :: Maybe Font, _txsFontSize :: Maybe FontSize, - _txsColor :: Maybe Color, + _txsFontColor :: Maybe Color, _txsAlignH :: Maybe AlignH, _txsAlignV :: Maybe AlignV } deriving (Show, Eq) @@ -243,7 +248,7 @@ instance Default TextStyle where def = TextStyle { _txsFont = Nothing, _txsFontSize = Nothing, - _txsColor = Nothing, + _txsFontColor = Nothing, _txsAlignH = Nothing, _txsAlignV = Nothing } @@ -252,7 +257,7 @@ instance Semigroup TextStyle where (<>) ts1 ts2 = TextStyle { _txsFont = _txsFont ts2 <|> _txsFont ts1, _txsFontSize = _txsFontSize ts2 <|> _txsFontSize ts1, - _txsColor = _txsColor ts2 <|> _txsColor ts1, + _txsFontColor = _txsFontColor ts2 <|> _txsFontColor ts1, _txsAlignH = _txsAlignH ts2 <|> _txsAlignH ts1, _txsAlignV = _txsAlignV ts2 <|> _txsAlignV ts1 } diff --git a/src/Monomer/Common/StyleCombinators.hs b/src/Monomer/Common/StyleCombinators.hs index 240acc08..c60abea8 100644 --- a/src/Monomer/Common/StyleCombinators.hs +++ b/src/Monomer/Common/StyleCombinators.hs @@ -120,6 +120,9 @@ bgColor col = def & L.bgColor ?~ col fgColor :: Color -> StyleState fgColor col = def & L.fgColor ?~ col +hlColor :: Color -> StyleState +hlColor col = def & L.hlColor ?~ col + textFont :: Font -> StyleState textFont font = def & L.text . non def . L.font ?~ font @@ -127,7 +130,7 @@ textSize :: Double -> StyleState textSize size = def & L.text . non def . L.fontSize ?~ FontSize size textColor :: Color -> StyleState -textColor col = def & L.text . non def . L.color ?~ col +textColor col = def & L.text . non def . L.fontColor ?~ col textAlignH :: AlignH -> StyleState textAlignH align = def & L.text . non def . L.alignH ?~ align diff --git a/src/Monomer/Common/StyleUtil.hs b/src/Monomer/Common/StyleUtil.hs index 359fc35e..37b86698 100644 --- a/src/Monomer/Common/StyleUtil.hs +++ b/src/Monomer/Common/StyleUtil.hs @@ -4,13 +4,7 @@ module Monomer.Common.StyleUtil ( addOuterBounds, removeOuterSize, removeOuterBounds, - subtractMargin, - textStyle, - textFont, - textSize, - textColor, - textAlignH, - textAlignV + subtractMargin ) where import Data.Default @@ -20,34 +14,18 @@ import Monomer.Common.Geometry import Monomer.Common.Style import Monomer.Graphics.Types -textStyle :: StyleState -> TextStyle -textStyle sst = fromMaybe def (_sstText sst) - -textFont :: StyleState -> Font -textFont style = fromMaybe def (_txsFont $ textStyle style) - -textSize :: StyleState -> FontSize -textSize style = fromMaybe def (_txsFontSize $ textStyle style) - -textColor :: StyleState -> Color -textColor style = fromMaybe def (_txsColor $ textStyle style) - -textAlignH :: StyleState -> AlignH -textAlignH style = fromMaybe def (_txsAlignH $ textStyle style) - -textAlignV :: StyleState -> AlignV -textAlignV style = fromMaybe def (_txsAlignV $ textStyle style) - mergeThemeStyle :: ThemeState -> StyleState -> StyleState mergeThemeStyle theme style = newStyle where + themeFgColor = Just $ _thsFgColor theme + themeHlColor = Just $ _thsHlColor theme themeText = Just def { _txsFont = Just $ _thsFont theme, _txsFontSize = Just $ _thsFontSize theme, - _txsColor = Just $ _thsColor theme + _txsFontColor = Just $ _thsFontColor theme } - themeFgColor = Just $ _thsFgColor theme newStyle = style { _sstFgColor = _sstFgColor style <> themeFgColor, + _sstHlColor = _sstHlColor style <> themeHlColor, _sstText = _sstText style <> themeText } diff --git a/src/Monomer/Graphics/Drawing.hs b/src/Monomer/Graphics/Drawing.hs index 758cd23a..069c8a1b 100644 --- a/src/Monomer/Graphics/Drawing.hs +++ b/src/Monomer/Graphics/Drawing.hs @@ -85,7 +85,7 @@ drawStyledText :: Renderer -> Rect -> StyleState -> Text -> IO Rect drawStyledText renderer viewport style txt = action where action = drawText renderer viewport tsColor tsFont tsFontSize tsAlign txt TextStyle{..} = fromMaybe def (_sstText style) - tsColor = justDef _txsColor + tsColor = justDef _txsFontColor tsFont = justDef _txsFont tsFontSize = fromMaybe def _txsFontSize tsAlignH = justDef _txsAlignH diff --git a/src/Monomer/Widget/Util.hs b/src/Monomer/Widget/Util.hs index dd4c6cc5..c2cc66d4 100644 --- a/src/Monomer/Widget/Util.hs +++ b/src/Monomer/Widget/Util.hs @@ -274,11 +274,6 @@ getContentRect style inst = removeOuterBounds style (_wiRenderArea inst) isFocused :: WidgetEnv s e -> WidgetInstance s e -> Bool isFocused wenv widgetInst = _weFocusedPath wenv == _wiPath widgetInst -instanceStyle :: WidgetEnv s e -> WidgetInstance s e -> StyleState -instanceStyle wenv inst = mergeThemeStyle theme style where - style = activeStyle wenv inst - theme = activeTheme wenv inst - activeStyle :: WidgetEnv s e -> WidgetInstance s e -> StyleState activeStyle wenv inst = fromMaybe def styleState where Style{..} = _wiStyle inst @@ -302,12 +297,49 @@ activeTheme wenv inst = themeState where | isFocus = _themeFocus theme | otherwise = _themeBasic theme -activeFgColor :: WidgetEnv s e -> WidgetInstance s e -> Color -activeFgColor wenv inst = fromMaybe themeColor styleColor where +instanceStyle :: WidgetEnv s e -> WidgetInstance s e -> StyleState +instanceStyle wenv inst = mergeThemeStyle theme style where + style = activeStyle wenv inst + theme = activeTheme wenv inst + +instanceFgColor :: WidgetEnv s e -> WidgetInstance s e -> Color +instanceFgColor wenv inst = fromMaybe themeColor styleColor where style = activeStyle wenv inst theme = activeTheme wenv inst - styleColor = style ^. S.fgColor - themeColor = theme ^. S.fgColor + styleColor = _sstFgColor style + themeColor = _thsFgColor theme + +instanceHlColor :: WidgetEnv s e -> WidgetInstance s e -> Color +instanceHlColor wenv inst = fromMaybe themeColor styleColor where + style = activeStyle wenv inst + theme = activeTheme wenv inst + styleColor = _sstHlColor style + themeColor = _thsHlColor theme + +instanceTextStyle :: WidgetEnv s e -> WidgetInstance s e -> TextStyle +instanceTextStyle wenv inst = textStyle <> textTheme where + style = activeStyle wenv inst + theme = activeTheme wenv inst + textStyle = fromMaybe def (_sstText style) + textTheme = TextStyle { + _txsFont = Just (_thsFont theme), + _txsFontSize = Just (_thsFontSize theme), + _txsFontColor = Just (_thsFontColor theme), + _txsAlignH = Nothing, + _txsAlignV = Nothing + } + +instanceFont :: WidgetEnv s e -> WidgetInstance s e -> Font +instanceFont wenv inst = fromJust (_txsFont textStyle) where + textStyle = instanceTextStyle wenv inst + +instanceFontSize :: WidgetEnv s e -> WidgetInstance s e -> FontSize +instanceFontSize wenv inst = fromJust (_txsFontSize textStyle) where + textStyle = instanceTextStyle wenv inst + +instanceFontColor :: WidgetEnv s e -> WidgetInstance s e -> Color +instanceFontColor wenv inst = fromJust (_txsFontColor textStyle) where + textStyle = instanceTextStyle wenv inst resizeInstance :: WidgetEnv s e -> WidgetInstance s e -> WidgetInstance s e resizeInstance wenv inst = newInst where diff --git a/src/Monomer/Widget/Widgets/Checkbox.hs b/src/Monomer/Widget/Widgets/Checkbox.hs index 61498ea8..7bd140e6 100644 --- a/src/Monomer/Widget/Widgets/Checkbox.hs +++ b/src/Monomer/Widget/Widgets/Checkbox.hs @@ -84,7 +84,7 @@ makeCheckbox config = widget where checkboxT = _rY rarea sz = min (_rW rarea) (_rH rarea) checkboxArea = Rect checkboxL checkboxT sz sz - fgColor = activeFgColor wenv inst + fgColor = instanceFgColor wenv inst renderCheckbox :: Renderer -> CheckboxCfg s e -> Rect -> Color -> IO () renderCheckbox renderer config rect color = action where diff --git a/src/Monomer/Widget/Widgets/Radio.hs b/src/Monomer/Widget/Widgets/Radio.hs index 476cfc44..fabc2079 100644 --- a/src/Monomer/Widget/Widgets/Radio.hs +++ b/src/Monomer/Widget/Widgets/Radio.hs @@ -86,7 +86,7 @@ makeRadio config = widget where radioT = _rY rarea sz = min (_rW rarea) (_rH rarea) radioArea = Rect radioL radioT sz sz - fgColor = activeFgColor wenv inst + fgColor = instanceFgColor wenv inst renderRadio :: Renderer -> RadioCfg s e a -> Rect -> Color -> IO () renderRadio renderer config rect color = action where diff --git a/src/Monomer/Widget/Widgets/TextField.hs b/src/Monomer/Widget/Widgets/TextField.hs index ef4f5aa7..717a8fc2 100644 --- a/src/Monomer/Widget/Widgets/TextField.hs +++ b/src/Monomer/Widget/Widgets/TextField.hs @@ -10,7 +10,7 @@ module Monomer.Widget.Widgets.TextField ( ) where import Control.Monad -import Control.Lens (ALens', (&), (.~), (^.), (^?)) +import Control.Lens (ALens', (&), (.~), (^.), (^?), _Just, non) import Data.Default import Data.Maybe import Data.Sequence (Seq, (|>)) @@ -31,6 +31,8 @@ import Monomer.Widget.BaseSingle import Monomer.Widget.Types import Monomer.Widget.Util +import qualified Monomer.Common.LensStyle as S + data TextFieldCfg s e = TextFieldCfg { _tfcValue :: WidgetValue s Text, _tfcOnChange :: [Text -> e], @@ -255,20 +257,18 @@ makeTextField config state = widget where render renderer wenv inst = do setScissor renderer contentRect - textRect <- renderContent renderer state contentRect mergedStyle currText + textRect <- renderContent renderer state contentRect style currText when (isJust currSel) $ - drawRect renderer (selRect textRect) selColor Nothing + drawRect renderer (selRect textRect) (Just selColor) Nothing when (isFocused wenv inst) $ - drawRect renderer (caretRect textRect) caretColor Nothing + drawRect renderer (caretRect textRect) (Just caretColor) Nothing resetScissor renderer where WidgetInstance{..} = inst - theme = activeTheme wenv inst - style = activeStyle wenv inst - mergedStyle = mergeThemeStyle theme style + style = instanceStyle wenv inst contentRect = getContentRect style inst Rect cx cy cw ch = contentRect selRect textRect = maybe def (mkSelRect textRect) currSel @@ -282,11 +282,11 @@ makeTextField config state = widget where selAlpha | isFocused wenv inst = 0.5 | otherwise = 0.3 - selColor = Just $ textColor style & alpha .~ selAlpha + selColor = instanceHlColor wenv inst & alpha .~ selAlpha caretAlpha | isFocused wenv inst = if (ts `mod` 1000) < 500 then 1 else 0 | otherwise = 0 - caretColor = Just $ textColor style & alpha .~ caretAlpha + caretColor = instanceFontColor wenv inst & alpha .~ caretAlpha caretWidth = _tfcCaretWidth config caretPos | currPos == 0 = 0 @@ -302,10 +302,11 @@ renderContent renderer state viewport style currText = Rect x y w h = viewport textW = glyphsLength $ _tfGlyphs state !tsRect = Rect (x + _tfOffset state) y textW h - tsFont = textFont style - tsFontSize = textSize style - tsColor = textColor style - tsAlignV = textAlignV style + textStyle = fromJust (_sstText style) + tsFont = fromJust (_txsFont textStyle) + tsFontSize = fromJust (_txsFontSize textStyle) + tsColor = fromJust (_txsFontColor textStyle) + tsAlignV = fromMaybe AMiddle (_txsAlignV textStyle) tsAlign = Align ALeft tsAlignV newTextState @@ -318,14 +319,15 @@ newTextState -> TextFieldState newTextState wenv inst oldState text cursor selection = newState where theme = activeTheme wenv inst - style = activeStyle wenv inst + style = instanceStyle wenv inst Rect cx cy cw ch = getContentRect style inst glyphs = getTextGlyphs wenv theme style text curX = maybe 0 _glpXMax $ Seq.lookup (cursor - 1) glyphs oldOffset = _tfOffset oldState textW = glyphsLength glyphs textFits = cw >= textW - align = fromMaybe ALeft (_txsAlignH $ textStyle style) + textStyle = fromJust (_sstText style) + align = fromMaybe ALeft (_txsAlignH textStyle) newOffset | textFits && align == ALeft = 0 | textFits && align == ACenter = (cw - textW) / 2