mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-20 16:27:49 +03:00
Add config/theming options to scroll
This commit is contained in:
parent
ce9f16f4b6
commit
86ca5efd80
@ -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],
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
5
tasks.md
5
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)
|
||||
|
Loading…
Reference in New Issue
Block a user