Add theming to scroll

app/Main.hs

@@ -78,8 +78,10 @@ handleAppEvent model evt = case evt of
   _ -> []
 
 buildUI :: App -> WidgetInstance App AppEvent
-buildUI model = trace "Creating UI" widgetTree7 where
-  wid = checkbox condition1 `style` [fgColor yellow, bgColor orange]
+buildUI model = trace "Creating UI" widgetTree8 where
+  --widgetTree8 = box (image_ "assets/images/pecans.jpg" [fitFill] `style` [width 200])
+  --widgetTree8 = hstack [image_ "assets/images/pecans.jpg" [fitFill] `style` [width 200]] --
+  widgetTree8 = scroll (image_ "assets/images/beach.jpg" [fitFill]) `style` [width 200]
   widgetTree7 = hstack [
       checkbox condition1 `style` [fgColor yellow, bgColor orange],
       radio fruit Apple `style` [fgColor brown, bgColor yellow]

src/Monomer/Core/ThemeTypes.hs

@@ -33,10 +33,9 @@ data ThemeState = ThemeState {
   _thsFgColor :: Color,
   _thsHlColor :: Color,
   _thsEmptyOverlayColor :: Color,
-  _thsScrollColor :: Color,
-  _thsScrollIdleColor :: Color,
-  _thsThumbColor :: Color,
-  _thsThumbIdleColor :: Color,
+  _thsScrollBarColor :: Color,
+  _thsScrollThumbColor :: Color,
+  _thsScrollWidth :: Double,
   _thsCheckboxColor :: Color,
   _thsCheckboxWidth :: Double,
   _thsRadioColor :: Color,
@@ -55,10 +54,9 @@ instance Default ThemeState where
     _thsFgColor = def,
     _thsHlColor = def,
     _thsEmptyOverlayColor = def,
-    _thsScrollColor = def,
-    _thsScrollIdleColor = def,
-    _thsThumbColor = def,
-    _thsThumbIdleColor = def,
+    _thsScrollBarColor = def,
+    _thsScrollThumbColor = def,
+    _thsScrollWidth = def,
     _thsCheckboxColor = def,
     _thsCheckboxWidth = def,
     _thsRadioColor = def,

src/Monomer/Core/Themes/Dark.hs

@@ -40,10 +40,9 @@ darkBasic = def
   & L.fgColor .~ blue
   & L.hlColor .~ white
   & L.emptyOverlayColor .~ (darkGray & L.a .~ 0.8)
-  & L.scrollColor .~ (darkGray & L.a .~ 0.4)
-  & L.scrollIdleColor .~ (darkGray & L.a .~ 0.2)
-  & L.thumbColor .~ (gray & L.a .~ 0.8)
-  & L.thumbIdleColor .~ (gray & L.a .~ 0.6)
+  & L.scrollBarColor .~ (gray & L.a .~ 0.2)
+  & L.scrollThumbColor .~ (darkGray & L.a .~ 0.6)
+  & L.scrollWidth .~ 10
   & L.checkboxColor .~ blue
   & L.checkboxWidth .~ 25
   & L.radioColor .~ red
@@ -69,6 +68,8 @@ darkBasic = def
 
 darkHover :: ThemeState
 darkHover = darkBasic
+  & L.scrollBarColor .~ (gray & L.a .~ 0.4)
+  & L.scrollThumbColor .~ (darkGray & L.a .~ 0.8)
 
 darkFocus :: ThemeState
 darkFocus = darkBasic

src/Monomer/Widgets/Checkbox.hs

@@ -111,7 +111,6 @@ makeCheckbox widgetData config = widget where
 
   getSizeReq wenv inst = req where
     theme = activeTheme wenv inst
-    style = activeStyle wenv inst
     width = fromMaybe (theme ^. L.checkboxWidth) (_ckcWidth config)
     req = (FixedSize width, FixedSize width)
 

src/Monomer/Widgets/Scroll.hs

@@ -5,10 +5,11 @@ module Monomer.Widgets.Scroll (
   ScrollMessage(..),
   scroll,
   scroll_,
+  barHoverColor,
   barColor,
-  barIdleColor,
+  thumbHoverColor,
   thumbColor,
-  thumbIdleColor
+  barWidth
 ) where
 
 import Control.Applicative ((<|>))
@@ -31,33 +32,37 @@ data ActiveBar
 
 data ScrollCfg = ScrollCfg {
   _scBarColor :: Maybe Color,
-  _scBarIdleColor :: Maybe Color,
+  _scBarHoverColor :: Maybe Color,
   _scThumbColor :: Maybe Color,
-  _scThumbIdleColor :: Maybe Color
+  _scThumbHoverColor :: Maybe Color,
+  _scWidth :: Maybe Double
 }
 
 instance Default ScrollCfg where
   def = ScrollCfg {
     _scBarColor = Nothing,
-    _scBarIdleColor = Nothing,
+    _scBarHoverColor = Nothing,
     _scThumbColor = Nothing,
-    _scThumbIdleColor = Nothing
+    _scThumbHoverColor = Nothing,
+    _scWidth = Nothing
   }
 
 instance Semigroup ScrollCfg where
   (<>) t1 t2 = ScrollCfg {
     _scBarColor = _scBarColor t2 <|> _scBarColor t1,
-    _scBarIdleColor = _scBarIdleColor t2 <|> _scBarIdleColor t1,
+    _scBarHoverColor = _scBarHoverColor t2 <|> _scBarHoverColor t1,
     _scThumbColor = _scThumbColor t2 <|> _scThumbColor t1,
-    _scThumbIdleColor = _scThumbIdleColor t2 <|> _scThumbIdleColor t1
+    _scThumbHoverColor = _scThumbHoverColor t2 <|> _scThumbHoverColor t1,
+    _scWidth = _scWidth t2 <|> _scWidth t1
   }
 
 instance Monoid ScrollCfg where
   mempty = ScrollCfg {
     _scBarColor = Nothing,
-    _scBarIdleColor = Nothing,
+    _scBarHoverColor = Nothing,
     _scThumbColor = Nothing,
-    _scThumbIdleColor = Nothing
+    _scThumbHoverColor = Nothing,
+    _scWidth = Nothing
   }
 
 data ScrollState = ScrollState {
@@ -99,9 +104,9 @@ barColor col = def {
   _scBarColor = Just col
 }
 
-barIdleColor :: Color -> ScrollCfg
-barIdleColor col = def {
-  _scBarIdleColor = Just col
+barHoverColor :: Color -> ScrollCfg
+barHoverColor col = def {
+  _scBarHoverColor = Just col
 }
 
 thumbColor :: Color -> ScrollCfg
@@ -109,13 +114,15 @@ thumbColor col = def {
   _scThumbColor = Just col
 }
 
-thumbIdleColor :: Color -> ScrollCfg
-thumbIdleColor col = def {
-  _scThumbIdleColor = Just col
+thumbHoverColor :: Color -> ScrollCfg
+thumbHoverColor col = def {
+  _scThumbHoverColor = Just col
 }
 
-barThickness :: Double
-barThickness = 10
+barWidth :: Double -> ScrollCfg
+barWidth w = def {
+  _scWidth = Just w
+}
 
 wheelRate :: Double
 wheelRate = 10
@@ -214,7 +221,7 @@ makeScroll config state = widget where
     where
       renderArea = _wiRenderArea inst
       Rect rx ry rw rh = _wiRenderArea inst
-      sctx@ScrollContext{..} = scrollStatus config wenv state renderArea
+      sctx@ScrollContext{..} = scrollStatus config wenv state inst
       scrollReqs = [IgnoreChildrenEvents, IgnoreParentEvents]
 
   scrollAxis reqDelta childLength vpLength
@@ -337,41 +344,53 @@ makeScroll config state = widget where
       drawRect renderer vThumbRect thumbColorV Nothing
 
     where
-      theme = activeTheme wenv inst
+      theme = wenv ^. L.theme
       viewport = _wiViewport inst
       renderArea = _wiRenderArea inst
-      ScrollContext{..} = scrollStatus config wenv state renderArea
+      ScrollContext{..} = scrollStatus config wenv state inst
       draggingH = _sstDragging state == Just HBar
       draggingV = _sstDragging state == Just VBar
-      activeBarCol = _scBarColor config <|> Just (theme ^. L.scrollColor)
-      idleBarCol = _scBarIdleColor config <|> Just (theme ^. L.scrollIdleColor)
-      activeThumbCol = _scThumbColor config <|> Just (theme ^. L.thumbColor)
-      idleThumbCol = _scThumbIdleColor config <|> Just (theme ^. L.thumbIdleColor)
+      instBarBCol = _scBarColor config
+      instBarHCol = _scBarHoverColor config
+      instThumbBCol = _scThumbColor config
+      instThumbHCol = _scThumbHoverColor config
+
+      barBCol = instBarBCol <|> Just (theme ^. L.basic . L.scrollBarColor)
+      barHCol = instBarHCol <|> Just (theme ^. L.hover . L.scrollBarColor)
+      thumbBCol = instThumbBCol <|> Just (theme ^. L.basic . L.scrollThumbColor)
+      thumbHCol = instThumbHCol <|> Just (theme ^. L.hover. L.scrollThumbColor)
 
       barColorH
-        | hMouseInScroll = activeBarCol
-        | otherwise = idleBarCol
+        | hMouseInScroll = barHCol
+        | otherwise = barBCol
       barColorV
-        | vMouseInScroll = activeBarCol
-        | otherwise = idleBarCol
+        | vMouseInScroll = barHCol
+        | otherwise = barBCol
       thumbColorH
-        | hMouseInThumb || draggingH = activeThumbCol
-        | otherwise = idleThumbCol
+        | hMouseInThumb || draggingH = thumbHCol
+        | otherwise = thumbBCol
       thumbColorV
-        | vMouseInThumb || draggingV = activeThumbCol
-        | otherwise = idleThumbCol
+        | vMouseInThumb || draggingV = thumbHCol
+        | otherwise = thumbBCol
 
 scrollStatus
-  :: ScrollCfg -> WidgetEnv s e -> ScrollState -> Rect -> ScrollContext
-scrollStatus config wenv scrollState renderArea = ScrollContext{..} where
+  :: ScrollCfg
+  -> WidgetEnv s e
+  -> ScrollState
+  -> WidgetInstance s e
+  -> ScrollContext
+scrollStatus config wenv scrollState inst = ScrollContext{..} where
   ScrollState _ dx dy (Size childWidth childHeight) = scrollState
   mousePos = _ipsMousePos (_weInputStatus wenv)
+  theme = activeTheme wenv inst
+  renderArea = _wiRenderArea inst
+  barW = fromMaybe (theme ^. L.scrollWidth) (_scWidth config)
   raLeft = _rX renderArea
   raTop = _rY renderArea
   raWidth = _rW renderArea
   raHeight = _rH renderArea
-  hScrollTop = raHeight - barThickness
-  vScrollLeft = raWidth - barThickness
+  hScrollTop = raHeight - barW
+  vScrollLeft = raWidth - barW
   hScrollRatio = min (raWidth / childWidth) 1
   vScrollRatio = min (raHeight / childHeight) 1
   hScrollRequired = hScrollRatio < 1
@@ -392,12 +411,12 @@ scrollStatus config wenv scrollState renderArea = ScrollContext{..} where
     _rX = raLeft - hScrollRatio * dx,
     _rY = raTop + hScrollTop,
     _rW = hScrollRatio * raWidth,
-    _rH = barThickness
+    _rH = barW
   }
   vThumbRect = Rect {
     _rX = raLeft + vScrollLeft,
     _rY = raTop - vScrollRatio * dy,
-    _rW = barThickness,
+    _rW = barW,
     _rH = vScrollRatio * raHeight
   }
   hMouseInScroll = pointInRect mousePos hScrollRect