Add highlighted color

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
   }

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

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
   }
 

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

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

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

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

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