Add config/theming options to scroll

app/Main.hs

@@ -253,7 +253,7 @@ buildUI wenv model = trace "Creating UI" widgetTree where
       ] `hover` [bgColor red],
       hstack [
         scroll_ (
-          scroll (image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200])
+          image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200]
         ) []
         ,
         spacer_ [resizeFactor 1],

src/Monomer/Core/ThemeTypes.hs

@@ -54,7 +54,10 @@ data ThemeState = ThemeState {
   _thsRadioStyle :: StyleState,
   _thsScrollBarColor :: Color,
   _thsScrollThumbColor :: Color,
-  _thsScrollWidth :: Double,
+  _thsScrollBarWidth :: Double,
+  _thsScrollThumbWidth :: Double,
+  _thsScrollThumbRadius :: Double,
+  _thsScrollWheelRate :: Double,
   _thsUserStyleMap :: M.Map String StyleState
 } deriving (Eq, Show)
 
@@ -89,6 +92,9 @@ instance Default ThemeState where
     _thsRadioStyle = def,
     _thsScrollBarColor = def,
     _thsScrollThumbColor = def,
-    _thsScrollWidth = def,
+    _thsScrollBarWidth = 10,
+    _thsScrollThumbWidth = 8,
+    _thsScrollThumbRadius = 0,
+    _thsScrollWheelRate = 10,
     _thsUserStyleMap = M.empty
   }

src/Monomer/Core/Themes/Dark.hs

@@ -113,7 +113,10 @@ darkBasic = def
   & L.radioStyle . L.fgColor ?~ gray
   & L.scrollBarColor .~ (gray & L.a .~ 0.2)
   & L.scrollThumbColor .~ (darkGray & L.a .~ 0.6)
-  & L.scrollWidth .~ 10
+  & L.scrollBarWidth .~ 10
+  & L.scrollThumbWidth .~ 8
+  & L.scrollThumbRadius .~ 4
+  & L.scrollWheelRate .~ 10
 
 darkHover :: ThemeState
 darkHover = darkBasic

src/Monomer/Widgets/Scroll.hs

@@ -11,12 +11,15 @@ module Monomer.Widgets.Scroll (
   hscroll_,
   vscroll,
   vscroll_,
-  barHoverColor,
-  barColor,
-  thumbHoverColor,
-  thumbColor,
+  scrollWheelRate,
+  scrollBarHoverColor,
+  scrollBarColor,
+  scrollThumbHoverColor,
+  scrollThumbColor,
   scrollStyle,
-  barWidth
+  scrollBarWidth,
+  scrollThumbWidth,
+  scrollThumbRadius
 ) where
 
 import Control.Applicative ((<|>))
@@ -24,7 +27,6 @@ import Control.Lens (ALens', (&), (^.), (.~), (^?!), cloneLens, ix)
 import Control.Monad
 import Data.Default
 import Data.Maybe
-import Data.Sequence (Seq)
 import Data.Typeable
 
 import qualified Data.Sequence as Seq
@@ -46,34 +48,43 @@ data ActiveBar
 
 data ScrollCfg = ScrollCfg {
   _scScrollType :: Maybe ScrollType,
+  _scWheelRate :: Maybe Double,
   _scBarColor :: Maybe Color,
   _scBarHoverColor :: Maybe Color,
   _scThumbColor :: Maybe Color,
   _scThumbHoverColor :: Maybe Color,
   _scStyle :: Maybe (ALens' ThemeState StyleState),
-  _scWidth :: Maybe Double
+  _scBarWidth :: Maybe Double,
+  _scThumbWidth :: Maybe Double,
+  _scThumbRadius :: Maybe Double
 }
 
 instance Default ScrollCfg where
   def = ScrollCfg {
     _scScrollType = Nothing,
+    _scWheelRate = Nothing,
     _scBarColor = Nothing,
     _scBarHoverColor = Nothing,
     _scThumbColor = Nothing,
     _scThumbHoverColor = Nothing,
     _scStyle = Nothing,
-    _scWidth = Nothing
+    _scBarWidth = Nothing,
+    _scThumbWidth = Nothing,
+    _scThumbRadius = Nothing
   }
 
 instance Semigroup ScrollCfg where
   (<>) t1 t2 = ScrollCfg {
     _scScrollType = _scScrollType t2 <|> _scScrollType t1,
+    _scWheelRate = _scWheelRate t2 <|> _scWheelRate t1,
     _scBarColor = _scBarColor t2 <|> _scBarColor t1,
     _scBarHoverColor = _scBarHoverColor t2 <|> _scBarHoverColor t1,
     _scThumbColor = _scThumbColor t2 <|> _scThumbColor t1,
     _scThumbHoverColor = _scThumbHoverColor t2 <|> _scThumbHoverColor t1,
     _scStyle = _scStyle t2 <|> _scStyle t1,
-    _scWidth = _scWidth t2 <|> _scWidth t1
+    _scBarWidth = _scBarWidth t2 <|> _scBarWidth t1,
+    _scThumbWidth = _scThumbWidth t2 <|> _scThumbWidth t1,
+    _scThumbRadius = _scThumbRadius t2 <|> _scThumbRadius t1
   }
 
 instance Monoid ScrollCfg where
@@ -118,29 +129,44 @@ scrollType st = def {
   _scScrollType = Just st
 }
 
-barColor :: Color -> ScrollCfg
-barColor col = def {
+scrollWheelRate :: Double -> ScrollCfg
+scrollWheelRate rate = def {
+  _scWheelRate = Just rate
+}
+
+scrollBarColor :: Color -> ScrollCfg
+scrollBarColor col = def {
   _scBarColor = Just col
 }
 
-barHoverColor :: Color -> ScrollCfg
-barHoverColor col = def {
+scrollBarHoverColor :: Color -> ScrollCfg
+scrollBarHoverColor col = def {
   _scBarHoverColor = Just col
 }
 
-thumbColor :: Color -> ScrollCfg
-thumbColor col = def {
+scrollThumbColor :: Color -> ScrollCfg
+scrollThumbColor col = def {
   _scThumbColor = Just col
 }
 
-thumbHoverColor :: Color -> ScrollCfg
-thumbHoverColor col = def {
+scrollThumbHoverColor :: Color -> ScrollCfg
+scrollThumbHoverColor col = def {
   _scThumbHoverColor = Just col
 }
 
-barWidth :: Double -> ScrollCfg
-barWidth w = def {
-  _scWidth = Just w
+scrollBarWidth :: Double -> ScrollCfg
+scrollBarWidth w = def {
+  _scBarWidth = Just w
+}
+
+scrollThumbWidth :: Double -> ScrollCfg
+scrollThumbWidth w = def {
+  _scThumbWidth = Just w
+}
+
+scrollThumbRadius :: Double -> ScrollCfg
+scrollThumbRadius r = def {
+  _scThumbRadius = Just r
 }
 
 scrollStyle :: ALens' ThemeState StyleState -> ScrollCfg
@@ -148,9 +174,6 @@ scrollStyle style = def {
   _scStyle = Just style
 }
 
-wheelRate :: Double
-wheelRate = 10
-
 scroll :: WidgetNode s e -> WidgetNode s e
 scroll managedWidget = scroll_ managedWidget [def]
 
@@ -252,11 +275,13 @@ makeScroll config state = widget where
       }
     _ -> Nothing
     where
+      theme = activeTheme wenv node
       style = scrollActiveStyle wenv node
       contentArea = getContentArea style node
       Rect cx cy cw ch = contentArea
       sctx@ScrollContext{..} = scrollStatus config wenv state node
       scrollReqs = [IgnoreChildrenEvents, IgnoreParentEvents]
+      wheelRate = fromMaybe (theme ^. L.scrollWheelRate) (_scWheelRate config)
 
   scrollAxis reqDelta childLength vpLength
     | maxDelta == 0 = 0
@@ -390,15 +415,20 @@ makeScroll config state = widget where
       drawRect renderer vScrollRect barColorV Nothing
 
     when hScrollRequired $
-      drawRect renderer hThumbRect thumbColorH Nothing
+      drawRect renderer hThumbRect thumbColorH thumbRadius
 
     when vScrollRequired $
-      drawRect renderer vThumbRect thumbColorV Nothing
+      drawRect renderer vThumbRect thumbColorV thumbRadius
     where
       ScrollContext{..} = scrollStatus config wenv state node
       draggingH = _sstDragging state == Just HBar
       draggingV = _sstDragging state == Just VBar
       theme = wenv ^. L.theme
+      athm = activeTheme wenv node
+      tmpRad = fromMaybe (athm ^. L.scrollThumbRadius) (_scThumbRadius config)
+      thumbRadius
+        | tmpRad > 0 = Just (radius tmpRad)
+        | otherwise = Nothing
 
       cfgBarBCol = _scBarColor config
       cfgBarHCol = _scBarHoverColor config
@@ -442,7 +472,8 @@ scrollStatus config wenv scrollState node = ScrollContext{..} where
   theme = activeTheme wenv node
   style = scrollActiveStyle wenv node
   contentArea = getContentArea style node
-  barW = fromMaybe (theme ^. L.scrollWidth) (_scWidth config)
+  barW = fromMaybe (theme ^. L.scrollBarWidth) (_scBarWidth config)
+  thumbW = fromMaybe (theme ^. L.scrollThumbWidth) (_scThumbWidth config)
   caLeft = _rX contentArea
   caTop = _rY contentArea
   caWidth = _rW contentArea
@@ -472,14 +503,14 @@ scrollStatus config wenv scrollState node = ScrollContext{..} where
   }
   hThumbRect = Rect {
     _rX = caLeft - hScrollRatio * dx,
-    _rY = caTop + hScrollTop,
+    _rY = caTop + hScrollTop + (barW - thumbW) / 2,
     _rW = hScrollRatio * caWidth,
-    _rH = barW
+    _rH = thumbW
   }
   vThumbRect = Rect {
-    _rX = caLeft + vScrollLeft,
+    _rX = caLeft + vScrollLeft + (barW - thumbW) / 2,
     _rY = caTop - vScrollRatio * dy,
-    _rW = barW,
+    _rW = thumbW,
     _rH = vScrollRatio * caHeight
   }
   hMouseInScroll = pointInRect mousePos hScrollRect

tasks.md

@@ -331,6 +331,7 @@
     - Can it be handled in Single/Container?
     - Handled in Single, not in Container, since it clashes with children. Handle explicitly on Containers that need it.
   - Restore focus to previous widget when zstack changes (dialog situation)
+  - Add config to invert mouse buttons (Core.hs:211)
 
 - Pending
   - Add testing
@@ -348,7 +349,6 @@
   - Add user documentation
 
 Maybe postponed after release?
-  - Add config to invert mouse buttons (Core.hs:211)
   - Scroll wheel rate should be configurable, or even depend on content size
   - Image
     - Can performance be improved? Use sbt functions?
@@ -356,7 +356,6 @@ Maybe postponed after release?
     - Remove delay logic when adding an image
     - When adding image, on failure remove an the least used image and retry
   - Make sure WidgetTask/Node association is preserved if node location in tree changes
-  - Check why after click focus is not immediately shown in listView items
   - Further textField improvements
     - Handle undo history
     - Handle mouse selection
@@ -364,6 +363,7 @@ Maybe postponed after release?
   - Check if SDL can be initialized headless (for tests that involve the API)
     - https://discourse.libsdl.org/t/possible-to-run-sdl2-headless/25665/2
   - ZStack should set _weIsTopLayer based on used space
+  - Check why after click focus is not immediately shown in listView items
   - Remove getSizeReq from Widget interface. Keep it in Single/Container
     - Other Widgets should take care of updating those fields during init/merge/handleEvent/handleMessage
   - Create Keystroke component (shortcuts and general key handling like Esc for dialog)
@@ -384,6 +384,7 @@ Maybe postponed after release?
     - SDL supports Drag and Drop integration with OS
   - Compare Cairo/Skia/ImDrawList interfaces to make Renderer able to handle future implementations
     - https://github.com/ollix/MetalNanoVG
+  - Implement ImDrawList based Renderer
   - Improve window resize situation
     - SDL does not send resize until operation has finished, making content look ugly because it's not updated
     - Check SDL_SetEventFilter trick instead of normal polling (https://wiki.libsdl.org/SDL_SetEventFilter)