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],
|
] `hover` [bgColor red],
|
||||||
hstack [
|
hstack [
|
||||||
scroll_ (
|
scroll_ (
|
||||||
scroll (image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200])
|
image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200]
|
||||||
) []
|
) []
|
||||||
,
|
,
|
||||||
spacer_ [resizeFactor 1],
|
spacer_ [resizeFactor 1],
|
||||||
|
@ -54,7 +54,10 @@ data ThemeState = ThemeState {
|
|||||||
_thsRadioStyle :: StyleState,
|
_thsRadioStyle :: StyleState,
|
||||||
_thsScrollBarColor :: Color,
|
_thsScrollBarColor :: Color,
|
||||||
_thsScrollThumbColor :: Color,
|
_thsScrollThumbColor :: Color,
|
||||||
_thsScrollWidth :: Double,
|
_thsScrollBarWidth :: Double,
|
||||||
|
_thsScrollThumbWidth :: Double,
|
||||||
|
_thsScrollThumbRadius :: Double,
|
||||||
|
_thsScrollWheelRate :: Double,
|
||||||
_thsUserStyleMap :: M.Map String StyleState
|
_thsUserStyleMap :: M.Map String StyleState
|
||||||
} deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
@ -89,6 +92,9 @@ instance Default ThemeState where
|
|||||||
_thsRadioStyle = def,
|
_thsRadioStyle = def,
|
||||||
_thsScrollBarColor = def,
|
_thsScrollBarColor = def,
|
||||||
_thsScrollThumbColor = def,
|
_thsScrollThumbColor = def,
|
||||||
_thsScrollWidth = def,
|
_thsScrollBarWidth = 10,
|
||||||
|
_thsScrollThumbWidth = 8,
|
||||||
|
_thsScrollThumbRadius = 0,
|
||||||
|
_thsScrollWheelRate = 10,
|
||||||
_thsUserStyleMap = M.empty
|
_thsUserStyleMap = M.empty
|
||||||
}
|
}
|
||||||
|
@ -113,7 +113,10 @@ darkBasic = def
|
|||||||
& L.radioStyle . L.fgColor ?~ gray
|
& L.radioStyle . L.fgColor ?~ gray
|
||||||
& L.scrollBarColor .~ (gray & L.a .~ 0.2)
|
& L.scrollBarColor .~ (gray & L.a .~ 0.2)
|
||||||
& L.scrollThumbColor .~ (darkGray & L.a .~ 0.6)
|
& 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 :: ThemeState
|
||||||
darkHover = darkBasic
|
darkHover = darkBasic
|
||||||
|
@ -11,12 +11,15 @@ module Monomer.Widgets.Scroll (
|
|||||||
hscroll_,
|
hscroll_,
|
||||||
vscroll,
|
vscroll,
|
||||||
vscroll_,
|
vscroll_,
|
||||||
barHoverColor,
|
scrollWheelRate,
|
||||||
barColor,
|
scrollBarHoverColor,
|
||||||
thumbHoverColor,
|
scrollBarColor,
|
||||||
thumbColor,
|
scrollThumbHoverColor,
|
||||||
|
scrollThumbColor,
|
||||||
scrollStyle,
|
scrollStyle,
|
||||||
barWidth
|
scrollBarWidth,
|
||||||
|
scrollThumbWidth,
|
||||||
|
scrollThumbRadius
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
@ -24,7 +27,6 @@ import Control.Lens (ALens', (&), (^.), (.~), (^?!), cloneLens, ix)
|
|||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Sequence (Seq)
|
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
|
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
@ -46,34 +48,43 @@ data ActiveBar
|
|||||||
|
|
||||||
data ScrollCfg = ScrollCfg {
|
data ScrollCfg = ScrollCfg {
|
||||||
_scScrollType :: Maybe ScrollType,
|
_scScrollType :: Maybe ScrollType,
|
||||||
|
_scWheelRate :: Maybe Double,
|
||||||
_scBarColor :: Maybe Color,
|
_scBarColor :: Maybe Color,
|
||||||
_scBarHoverColor :: Maybe Color,
|
_scBarHoverColor :: Maybe Color,
|
||||||
_scThumbColor :: Maybe Color,
|
_scThumbColor :: Maybe Color,
|
||||||
_scThumbHoverColor :: Maybe Color,
|
_scThumbHoverColor :: Maybe Color,
|
||||||
_scStyle :: Maybe (ALens' ThemeState StyleState),
|
_scStyle :: Maybe (ALens' ThemeState StyleState),
|
||||||
_scWidth :: Maybe Double
|
_scBarWidth :: Maybe Double,
|
||||||
|
_scThumbWidth :: Maybe Double,
|
||||||
|
_scThumbRadius :: Maybe Double
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Default ScrollCfg where
|
instance Default ScrollCfg where
|
||||||
def = ScrollCfg {
|
def = ScrollCfg {
|
||||||
_scScrollType = Nothing,
|
_scScrollType = Nothing,
|
||||||
|
_scWheelRate = Nothing,
|
||||||
_scBarColor = Nothing,
|
_scBarColor = Nothing,
|
||||||
_scBarHoverColor = Nothing,
|
_scBarHoverColor = Nothing,
|
||||||
_scThumbColor = Nothing,
|
_scThumbColor = Nothing,
|
||||||
_scThumbHoverColor = Nothing,
|
_scThumbHoverColor = Nothing,
|
||||||
_scStyle = Nothing,
|
_scStyle = Nothing,
|
||||||
_scWidth = Nothing
|
_scBarWidth = Nothing,
|
||||||
|
_scThumbWidth = Nothing,
|
||||||
|
_scThumbRadius = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Semigroup ScrollCfg where
|
instance Semigroup ScrollCfg where
|
||||||
(<>) t1 t2 = ScrollCfg {
|
(<>) t1 t2 = ScrollCfg {
|
||||||
_scScrollType = _scScrollType t2 <|> _scScrollType t1,
|
_scScrollType = _scScrollType t2 <|> _scScrollType t1,
|
||||||
|
_scWheelRate = _scWheelRate t2 <|> _scWheelRate t1,
|
||||||
_scBarColor = _scBarColor t2 <|> _scBarColor t1,
|
_scBarColor = _scBarColor t2 <|> _scBarColor t1,
|
||||||
_scBarHoverColor = _scBarHoverColor t2 <|> _scBarHoverColor t1,
|
_scBarHoverColor = _scBarHoverColor t2 <|> _scBarHoverColor t1,
|
||||||
_scThumbColor = _scThumbColor t2 <|> _scThumbColor t1,
|
_scThumbColor = _scThumbColor t2 <|> _scThumbColor t1,
|
||||||
_scThumbHoverColor = _scThumbHoverColor t2 <|> _scThumbHoverColor t1,
|
_scThumbHoverColor = _scThumbHoverColor t2 <|> _scThumbHoverColor t1,
|
||||||
_scStyle = _scStyle t2 <|> _scStyle 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
|
instance Monoid ScrollCfg where
|
||||||
@ -118,29 +129,44 @@ scrollType st = def {
|
|||||||
_scScrollType = Just st
|
_scScrollType = Just st
|
||||||
}
|
}
|
||||||
|
|
||||||
barColor :: Color -> ScrollCfg
|
scrollWheelRate :: Double -> ScrollCfg
|
||||||
barColor col = def {
|
scrollWheelRate rate = def {
|
||||||
|
_scWheelRate = Just rate
|
||||||
|
}
|
||||||
|
|
||||||
|
scrollBarColor :: Color -> ScrollCfg
|
||||||
|
scrollBarColor col = def {
|
||||||
_scBarColor = Just col
|
_scBarColor = Just col
|
||||||
}
|
}
|
||||||
|
|
||||||
barHoverColor :: Color -> ScrollCfg
|
scrollBarHoverColor :: Color -> ScrollCfg
|
||||||
barHoverColor col = def {
|
scrollBarHoverColor col = def {
|
||||||
_scBarHoverColor = Just col
|
_scBarHoverColor = Just col
|
||||||
}
|
}
|
||||||
|
|
||||||
thumbColor :: Color -> ScrollCfg
|
scrollThumbColor :: Color -> ScrollCfg
|
||||||
thumbColor col = def {
|
scrollThumbColor col = def {
|
||||||
_scThumbColor = Just col
|
_scThumbColor = Just col
|
||||||
}
|
}
|
||||||
|
|
||||||
thumbHoverColor :: Color -> ScrollCfg
|
scrollThumbHoverColor :: Color -> ScrollCfg
|
||||||
thumbHoverColor col = def {
|
scrollThumbHoverColor col = def {
|
||||||
_scThumbHoverColor = Just col
|
_scThumbHoverColor = Just col
|
||||||
}
|
}
|
||||||
|
|
||||||
barWidth :: Double -> ScrollCfg
|
scrollBarWidth :: Double -> ScrollCfg
|
||||||
barWidth w = def {
|
scrollBarWidth w = def {
|
||||||
_scWidth = Just w
|
_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
|
scrollStyle :: ALens' ThemeState StyleState -> ScrollCfg
|
||||||
@ -148,9 +174,6 @@ scrollStyle style = def {
|
|||||||
_scStyle = Just style
|
_scStyle = Just style
|
||||||
}
|
}
|
||||||
|
|
||||||
wheelRate :: Double
|
|
||||||
wheelRate = 10
|
|
||||||
|
|
||||||
scroll :: WidgetNode s e -> WidgetNode s e
|
scroll :: WidgetNode s e -> WidgetNode s e
|
||||||
scroll managedWidget = scroll_ managedWidget [def]
|
scroll managedWidget = scroll_ managedWidget [def]
|
||||||
|
|
||||||
@ -252,11 +275,13 @@ makeScroll config state = widget where
|
|||||||
}
|
}
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
where
|
where
|
||||||
|
theme = activeTheme wenv node
|
||||||
style = scrollActiveStyle wenv node
|
style = scrollActiveStyle wenv node
|
||||||
contentArea = getContentArea style node
|
contentArea = getContentArea style node
|
||||||
Rect cx cy cw ch = contentArea
|
Rect cx cy cw ch = contentArea
|
||||||
sctx@ScrollContext{..} = scrollStatus config wenv state node
|
sctx@ScrollContext{..} = scrollStatus config wenv state node
|
||||||
scrollReqs = [IgnoreChildrenEvents, IgnoreParentEvents]
|
scrollReqs = [IgnoreChildrenEvents, IgnoreParentEvents]
|
||||||
|
wheelRate = fromMaybe (theme ^. L.scrollWheelRate) (_scWheelRate config)
|
||||||
|
|
||||||
scrollAxis reqDelta childLength vpLength
|
scrollAxis reqDelta childLength vpLength
|
||||||
| maxDelta == 0 = 0
|
| maxDelta == 0 = 0
|
||||||
@ -390,15 +415,20 @@ makeScroll config state = widget where
|
|||||||
drawRect renderer vScrollRect barColorV Nothing
|
drawRect renderer vScrollRect barColorV Nothing
|
||||||
|
|
||||||
when hScrollRequired $
|
when hScrollRequired $
|
||||||
drawRect renderer hThumbRect thumbColorH Nothing
|
drawRect renderer hThumbRect thumbColorH thumbRadius
|
||||||
|
|
||||||
when vScrollRequired $
|
when vScrollRequired $
|
||||||
drawRect renderer vThumbRect thumbColorV Nothing
|
drawRect renderer vThumbRect thumbColorV thumbRadius
|
||||||
where
|
where
|
||||||
ScrollContext{..} = scrollStatus config wenv state node
|
ScrollContext{..} = scrollStatus config wenv state node
|
||||||
draggingH = _sstDragging state == Just HBar
|
draggingH = _sstDragging state == Just HBar
|
||||||
draggingV = _sstDragging state == Just VBar
|
draggingV = _sstDragging state == Just VBar
|
||||||
theme = wenv ^. L.theme
|
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
|
cfgBarBCol = _scBarColor config
|
||||||
cfgBarHCol = _scBarHoverColor config
|
cfgBarHCol = _scBarHoverColor config
|
||||||
@ -442,7 +472,8 @@ scrollStatus config wenv scrollState node = ScrollContext{..} where
|
|||||||
theme = activeTheme wenv node
|
theme = activeTheme wenv node
|
||||||
style = scrollActiveStyle wenv node
|
style = scrollActiveStyle wenv node
|
||||||
contentArea = getContentArea style 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
|
caLeft = _rX contentArea
|
||||||
caTop = _rY contentArea
|
caTop = _rY contentArea
|
||||||
caWidth = _rW contentArea
|
caWidth = _rW contentArea
|
||||||
@ -472,14 +503,14 @@ scrollStatus config wenv scrollState node = ScrollContext{..} where
|
|||||||
}
|
}
|
||||||
hThumbRect = Rect {
|
hThumbRect = Rect {
|
||||||
_rX = caLeft - hScrollRatio * dx,
|
_rX = caLeft - hScrollRatio * dx,
|
||||||
_rY = caTop + hScrollTop,
|
_rY = caTop + hScrollTop + (barW - thumbW) / 2,
|
||||||
_rW = hScrollRatio * caWidth,
|
_rW = hScrollRatio * caWidth,
|
||||||
_rH = barW
|
_rH = thumbW
|
||||||
}
|
}
|
||||||
vThumbRect = Rect {
|
vThumbRect = Rect {
|
||||||
_rX = caLeft + vScrollLeft,
|
_rX = caLeft + vScrollLeft + (barW - thumbW) / 2,
|
||||||
_rY = caTop - vScrollRatio * dy,
|
_rY = caTop - vScrollRatio * dy,
|
||||||
_rW = barW,
|
_rW = thumbW,
|
||||||
_rH = vScrollRatio * caHeight
|
_rH = vScrollRatio * caHeight
|
||||||
}
|
}
|
||||||
hMouseInScroll = pointInRect mousePos hScrollRect
|
hMouseInScroll = pointInRect mousePos hScrollRect
|
||||||
|
5
tasks.md
5
tasks.md
@ -331,6 +331,7 @@
|
|||||||
- Can it be handled in Single/Container?
|
- 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.
|
- 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)
|
- Restore focus to previous widget when zstack changes (dialog situation)
|
||||||
|
- Add config to invert mouse buttons (Core.hs:211)
|
||||||
|
|
||||||
- Pending
|
- Pending
|
||||||
- Add testing
|
- Add testing
|
||||||
@ -348,7 +349,6 @@
|
|||||||
- Add user documentation
|
- Add user documentation
|
||||||
|
|
||||||
Maybe postponed after release?
|
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
|
- Scroll wheel rate should be configurable, or even depend on content size
|
||||||
- Image
|
- Image
|
||||||
- Can performance be improved? Use sbt functions?
|
- Can performance be improved? Use sbt functions?
|
||||||
@ -356,7 +356,6 @@ Maybe postponed after release?
|
|||||||
- Remove delay logic when adding an image
|
- Remove delay logic when adding an image
|
||||||
- When adding image, on failure remove an the least used image and retry
|
- 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
|
- 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
|
- Further textField improvements
|
||||||
- Handle undo history
|
- Handle undo history
|
||||||
- Handle mouse selection
|
- Handle mouse selection
|
||||||
@ -364,6 +363,7 @@ Maybe postponed after release?
|
|||||||
- Check if SDL can be initialized headless (for tests that involve the API)
|
- 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
|
- https://discourse.libsdl.org/t/possible-to-run-sdl2-headless/25665/2
|
||||||
- ZStack should set _weIsTopLayer based on used space
|
- 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
|
- Remove getSizeReq from Widget interface. Keep it in Single/Container
|
||||||
- Other Widgets should take care of updating those fields during init/merge/handleEvent/handleMessage
|
- 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)
|
- 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
|
- SDL supports Drag and Drop integration with OS
|
||||||
- Compare Cairo/Skia/ImDrawList interfaces to make Renderer able to handle future implementations
|
- Compare Cairo/Skia/ImDrawList interfaces to make Renderer able to handle future implementations
|
||||||
- https://github.com/ollix/MetalNanoVG
|
- https://github.com/ollix/MetalNanoVG
|
||||||
|
- Implement ImDrawList based Renderer
|
||||||
- Improve window resize situation
|
- Improve window resize situation
|
||||||
- SDL does not send resize until operation has finished, making content look ugly because it's not updated
|
- 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)
|
- Check SDL_SetEventFilter trick instead of normal polling (https://wiki.libsdl.org/SDL_SetEventFilter)
|
||||||
|
Loading…
Reference in New Issue
Block a user