mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-20 08:17:37 +03:00
Standardize widget initialization
This commit is contained in:
Francisco Vallarino
parent
3a6231b31c
commit
43b53aef96
@ -59,7 +59,7 @@ handleKeysCompEvent app evt = case evt of
|
||||
|
||||
buildKeysComp app = trace "Created keys composite UI" $
|
||||
hgrid [
|
||||
button "Rotate" RotateChildren,
|
||||
button RotateChildren "Rotate",
|
||||
vgrid $ fmap (editableItem app) [0..(length (_items app) - 1)]
|
||||
]
|
||||
|
||||
|
||||
@ -67,14 +67,14 @@ buildComposite app = trace "Created composite UI" $
|
||||
scroll $ label "This is a composite label again!",
|
||||
vgrid [
|
||||
hgrid [
|
||||
button "Message parent" MessageParent
|
||||
button MessageParent "Message parent"
|
||||
],
|
||||
hgrid [
|
||||
sandbox CallSandbox,
|
||||
button "Run task" StartTask
|
||||
button StartTask "Run task"
|
||||
],
|
||||
hgrid [
|
||||
button "Run Producer" StartProducer,
|
||||
button StartProducer "Run Producer",
|
||||
label ("Produced: " <> showt (_csProduced app))
|
||||
]
|
||||
] `style` color gray
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Monomer.Widget.Widgets.Button (button) where
|
||||
module Monomer.Widget.Widgets.Button (ButtonConfig(..), button, button_) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Text (Text)
|
||||
@ -15,27 +15,38 @@ import Monomer.Widget.BaseWidget
|
||||
import Monomer.Widget.Types
|
||||
import Monomer.Widget.Util
|
||||
|
||||
button :: Text -> e -> WidgetInstance s e
|
||||
button label onClick = defaultWidgetInstance "button" (makeButton label onClick)
|
||||
data ButtonConfig s e = ButtonConfig {
|
||||
_btnLabel :: Text,
|
||||
_btnOnChange :: [e],
|
||||
_btnOnChangeReq :: [WidgetRequest s]
|
||||
}
|
||||
|
||||
makeButton :: Text -> e -> Widget s e
|
||||
makeButton label onClick = createWidget {
|
||||
button :: e -> Text -> WidgetInstance s e
|
||||
button onClick label = button_ config where
|
||||
config = ButtonConfig label [onClick] []
|
||||
|
||||
button_ :: ButtonConfig s e -> WidgetInstance s e
|
||||
button_ config = defaultWidgetInstance "button" (makeButton config)
|
||||
|
||||
makeButton :: ButtonConfig s e -> Widget s e
|
||||
makeButton config = createWidget {
|
||||
_widgetHandleEvent = handleEvent,
|
||||
_widgetPreferredSize = preferredSize,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
handleEvent wctx ctx evt widgetInstance = case evt of
|
||||
Click (Point x y) _ -> Just $ resultEvents events widgetInstance where
|
||||
events = [onClick]
|
||||
Click (Point x y) _ -> Just $ resultReqsEvents requests events widgetInstance where
|
||||
requests = _btnOnChangeReq config
|
||||
events = _btnOnChange config
|
||||
_ -> Nothing
|
||||
|
||||
preferredSize renderer wctx widgetInstance = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInstance
|
||||
size = calcTextBounds renderer _styleText label
|
||||
size = calcTextBounds renderer _styleText (_btnLabel config)
|
||||
sizeReq = SizeReq size FlexibleSize FlexibleSize
|
||||
|
||||
render renderer wctx ctx WidgetInstance{..} =
|
||||
do
|
||||
drawStyledBackground renderer _instanceRenderArea _instanceStyle
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle label
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle (_btnLabel config)
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Monomer.Widget.Widgets.Dropdown (dropdown) where
|
||||
module Monomer.Widget.Widgets.Dropdown (DropdownConfig(..), dropdown) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Lens (ALens', (&), (^#), (#~))
|
||||
@ -37,6 +37,8 @@ import Monomer.Widget.Widgets.ListView
|
||||
|
||||
data DropdownConfig s e a = DropdownConfig {
|
||||
_ddValue :: WidgetValue s a,
|
||||
_ddItems :: Seq a,
|
||||
_ddItemToText :: a -> Text,
|
||||
_ddOnChange :: [a -> e],
|
||||
_ddOnChangeReq :: [WidgetRequest s]
|
||||
}
|
||||
@ -48,12 +50,12 @@ newtype DropdownState = DropdownState {
|
||||
newtype DropdownMessage = OnChangeMessage Int deriving Typeable
|
||||
|
||||
dropdown :: (Traversable t, Eq a) => ALens' s a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
dropdown field items itemToText = dropdown_ config items itemToText where
|
||||
config = DropdownConfig (WidgetLens field) [] []
|
||||
|
||||
dropdown_ :: (Traversable t, Eq a) => DropdownConfig s e a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
dropdown_ config items itemToText = makeInstance (makeDropdown config newState newItems itemToText) where
|
||||
dropdown field items itemToText = dropdown_ config where
|
||||
config = DropdownConfig (WidgetLens field) newItems itemToText [] []
|
||||
newItems = foldl' (|>) Empty items
|
||||
|
||||
dropdown_ :: (Eq a) => DropdownConfig s e a -> WidgetInstance s e
|
||||
dropdown_ config = makeInstance (makeDropdown config newState) where
|
||||
newState = DropdownState False
|
||||
|
||||
makeInstance :: Widget s e -> WidgetInstance s e
|
||||
@ -61,8 +63,8 @@ makeInstance widget = (defaultWidgetInstance "dropdown" widget) {
|
||||
_instanceFocusable = True
|
||||
}
|
||||
|
||||
makeDropdown :: (Eq a) => DropdownConfig s e a -> DropdownState -> Seq a -> (a -> Text) -> Widget s e
|
||||
makeDropdown config state items itemToText = createContainer {
|
||||
makeDropdown :: (Eq a) => DropdownConfig s e a -> DropdownState -> Widget s e
|
||||
makeDropdown config state = createContainer {
|
||||
_widgetInit = containerInit init,
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = containerMergeTrees merge,
|
||||
@ -79,8 +81,8 @@ makeDropdown config state items itemToText = createContainer {
|
||||
createDropdown wctx ctx newState widgetInstance = newInstance where
|
||||
selected = currentValue wctx
|
||||
newInstance = widgetInstance {
|
||||
_instanceWidget = makeDropdown config newState items itemToText,
|
||||
_instanceChildren = Seq.singleton $ makeListView ctx items selected itemToText
|
||||
_instanceWidget = makeDropdown config newState,
|
||||
_instanceChildren = Seq.singleton $ makeListView config ctx selected
|
||||
}
|
||||
|
||||
init wctx ctx widgetInstance = resultWidget $ createDropdown wctx ctx state widgetInstance
|
||||
@ -109,10 +111,10 @@ makeDropdown config state items itemToText = createContainer {
|
||||
|
||||
handleOpenDropdown wctx ctx widgetInstance = resultReqs requests newInstance where
|
||||
selected = currentValue wctx
|
||||
selectedIdx = fromMaybe 0 (Seq.elemIndexL selected items)
|
||||
selectedIdx = fromMaybe 0 (Seq.elemIndexL selected (_ddItems config))
|
||||
newState = DropdownState True
|
||||
newInstance = widgetInstance {
|
||||
_instanceWidget = makeDropdown config newState items itemToText
|
||||
_instanceWidget = makeDropdown config newState
|
||||
}
|
||||
lvPath = currentPath (childContext ctx)
|
||||
requests = [SetOverlay (currentPath ctx), SetFocus lvPath]
|
||||
@ -120,12 +122,12 @@ makeDropdown config state items itemToText = createContainer {
|
||||
handleCloseDropdown wctx ctx widgetInstance = resultReqs requests newInstance where
|
||||
newState = DropdownState False
|
||||
newInstance = widgetInstance {
|
||||
_instanceWidget = makeDropdown config newState items itemToText
|
||||
_instanceWidget = makeDropdown config newState
|
||||
}
|
||||
requests = [ResetOverlay, SetFocus (currentPath ctx)]
|
||||
|
||||
handleMessage wctx ctx message widgetInstance = cast message
|
||||
>>= \(OnChangeMessage idx) -> Seq.lookup idx items
|
||||
>>= \(OnChangeMessage idx) -> Seq.lookup idx (_ddItems config)
|
||||
>>= \value -> Just $ handleOnChange wctx ctx idx value widgetInstance
|
||||
|
||||
handleOnChange wctx ctx idx item widgetInstance = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance where
|
||||
@ -161,13 +163,15 @@ makeDropdown config state items itemToText = createContainer {
|
||||
renderOverlay renderer wctx ctx overlayInstance = renderAction where
|
||||
renderAction = _widgetRender (_instanceWidget overlayInstance) renderer wctx (childContext ctx) overlayInstance
|
||||
|
||||
dropdownLabel wctx = itemToText $ currentValue wctx
|
||||
dropdownLabel wctx = _ddItemToText config $ currentValue wctx
|
||||
|
||||
makeListView :: (Eq a) => PathContext -> Seq a -> a -> (a -> Text) -> WidgetInstance s e
|
||||
makeListView ctx items selected itemToText = listView_ lvConfig items itemToText where
|
||||
makeListView :: (Eq a) => DropdownConfig s e a -> PathContext -> a -> WidgetInstance s e
|
||||
makeListView DropdownConfig{..} ctx selected = listView_ lvConfig where
|
||||
path = _pathCurrent ctx
|
||||
lvConfig = ListViewConfig {
|
||||
_lvValue = WidgetValue selected,
|
||||
_lvItems = _ddItems,
|
||||
_lvItemToText = _ddItemToText,
|
||||
_lvOnChange = [],
|
||||
_lvOnChangeReq = [SendMessage path . OnChangeMessage]
|
||||
}
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Monomer.Widget.Widgets.ListView (ListViewConfig(..), listView, listView_) where
|
||||
|
||||
@ -40,6 +41,8 @@ import Monomer.Widget.Widgets.Stack
|
||||
|
||||
data ListViewConfig s e a = ListViewConfig {
|
||||
_lvValue :: WidgetValue s a,
|
||||
_lvItems :: Seq a,
|
||||
_lvItemToText :: a -> Text,
|
||||
_lvOnChange :: [Int -> a -> e],
|
||||
_lvOnChangeReq :: [Int -> WidgetRequest s]
|
||||
}
|
||||
@ -51,12 +54,12 @@ newtype ListViewState = ListViewState {
|
||||
newtype ListViewMessage = OnClickMessage Int deriving Typeable
|
||||
|
||||
listView :: (Traversable t, Eq a) => ALens' s a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
listView field items itemToText = listView_ config items itemToText where
|
||||
config = ListViewConfig (WidgetLens field) [] []
|
||||
|
||||
listView_ :: (Traversable t, Eq a) => ListViewConfig s e a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
listView_ config items itemToText = makeInstance (makeListView config newState newItems itemToText) where
|
||||
listView field items itemToText = listView_ config where
|
||||
config = ListViewConfig (WidgetLens field) newItems itemToText [] []
|
||||
newItems = foldl' (|>) Empty items
|
||||
|
||||
listView_ :: (Eq a) => ListViewConfig s e a -> WidgetInstance s e
|
||||
listView_ config = makeInstance (makeListView config newState) where
|
||||
newState = ListViewState 0
|
||||
|
||||
makeInstance :: Widget s e -> WidgetInstance s e
|
||||
@ -64,8 +67,8 @@ makeInstance widget = (defaultWidgetInstance "listView" widget) {
|
||||
_instanceFocusable = True
|
||||
}
|
||||
|
||||
makeListView :: (Eq a) => ListViewConfig s e a -> ListViewState -> Seq a -> (a -> Text) -> Widget s e
|
||||
makeListView config state items itemToText = createContainer {
|
||||
makeListView :: (Eq a) => ListViewConfig s e a -> ListViewState -> Widget s e
|
||||
makeListView config state = createContainer {
|
||||
_widgetInit = init,
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = containerMergeTrees merge,
|
||||
@ -79,9 +82,9 @@ makeListView config state items itemToText = createContainer {
|
||||
|
||||
createListView wctx ctx newState widgetInstance = newInstance where
|
||||
selected = currentValue wctx
|
||||
itemsList = makeItemsList ctx items selected (_highlighted newState) itemToText
|
||||
itemsList = makeItemsList config ctx selected (_highlighted newState)
|
||||
newInstance = widgetInstance {
|
||||
_instanceWidget = makeListView config newState items itemToText,
|
||||
_instanceWidget = makeListView config newState,
|
||||
_instanceChildren = Seq.singleton (scroll itemsList)
|
||||
}
|
||||
|
||||
@ -99,7 +102,7 @@ makeListView config state items itemToText = createContainer {
|
||||
|
||||
handleHighlightNext wctx ctx widgetInstance = highlightItem wctx ctx widgetInstance nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
nextIdx = if tempIdx < length items - 1 then tempIdx + 1 else tempIdx
|
||||
nextIdx = if tempIdx < length (_lvItems config) - 1 then tempIdx + 1 else tempIdx
|
||||
|
||||
handleHighlightPrev wctx ctx widgetInstance = highlightItem wctx ctx widgetInstance nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
@ -110,7 +113,7 @@ makeListView config state items itemToText = createContainer {
|
||||
|
||||
highlightItem wctx ctx widgetInstance nextIdx = Just $ widgetResult { _resultRequests = requests } where
|
||||
newState = ListViewState nextIdx
|
||||
newWidget = makeListView config newState items itemToText
|
||||
newWidget = makeListView config newState
|
||||
-- ListView's merge uses the old widget's state. Since we want the newly created state, the old widget is replaced here
|
||||
oldInstance = widgetInstance {
|
||||
_instanceWidget = newWidget
|
||||
@ -123,14 +126,14 @@ makeListView config state items itemToText = createContainer {
|
||||
|
||||
selectItem wctx ctx widgetInstance idx = resultReqs requests newInstance where
|
||||
selected = currentValue wctx
|
||||
value = fromMaybe selected (Seq.lookup idx items)
|
||||
value = fromMaybe selected (Seq.lookup idx (_lvItems config))
|
||||
valueSetReq = widgetValueSet (_lvValue config) value
|
||||
scrollToReq = itemScrollTo ctx widgetInstance idx
|
||||
changeReqs = fmap ($ idx) (_lvOnChangeReq config)
|
||||
requests = valueSetReq ++ scrollToReq ++ changeReqs
|
||||
newState = ListViewState idx
|
||||
newInstance = widgetInstance {
|
||||
_instanceWidget = makeListView config newState items itemToText
|
||||
_instanceWidget = makeListView config newState
|
||||
}
|
||||
|
||||
itemScrollTo ctx widgetInstance idx = maybeToList (fmap makeScrollReq renderArea) where
|
||||
@ -149,15 +152,15 @@ makeListView config state items itemToText = createContainer {
|
||||
resize wctx viewport renderArea widgetInstance childrenPairs = (widgetInstance, assignedArea) where
|
||||
assignedArea = Seq.singleton (viewport, renderArea)
|
||||
|
||||
makeItemsList :: (Eq a) => PathContext -> Seq a -> a -> Int -> (a -> Text) -> WidgetInstance s e
|
||||
makeItemsList ctx items selected highlightedIdx itemToText = makeItemsList where
|
||||
makeItemsList :: (Eq a) => ListViewConfig s e a -> PathContext -> a -> Int -> WidgetInstance s e
|
||||
makeItemsList ListViewConfig{..} ctx selected highlightedIdx = makeItemsList where
|
||||
path = _pathCurrent ctx
|
||||
isSelected item = item == selected
|
||||
selectedColor item = if isSelected item then Just gray else Nothing
|
||||
highlightedColor idx = if idx == highlightedIdx then Just darkGray else Nothing
|
||||
pairs = Seq.zip (Seq.fromList [0..length items]) items
|
||||
pairs = Seq.zip (Seq.fromList [0..length _lvItems]) _lvItems
|
||||
makeItemsList = vstack $ fmap (uncurry makeItem) pairs
|
||||
makeItem idx item = container (config idx item) $ label (itemToText item)
|
||||
makeItem idx item = container (config idx item) $ label (_lvItemToText item)
|
||||
config idx item = def {
|
||||
_ctOnClickReq = [SendMessage path (OnClickMessage idx)],
|
||||
_ctBgColor = highlightedColor idx <|> selectedColor item,
|
||||
|
||||
@ -26,16 +26,25 @@ import Monomer.Widget.Util
|
||||
|
||||
data ActiveBar = HBar | VBar deriving (Eq)
|
||||
|
||||
newtype ScrollMessage = ScrollTo Rect deriving Typeable
|
||||
data ScrollConfig = ScrollConfig {
|
||||
_scActiveBarColor :: Maybe Color,
|
||||
_scIdleBarColor :: Maybe Color,
|
||||
_scActiveThumbColor :: Color,
|
||||
_scIdleThumbColor :: Color,
|
||||
_scBarThickness :: Double,
|
||||
_scWheelRate :: Double
|
||||
}
|
||||
|
||||
data ScrollState = ScrollState {
|
||||
_scDragging :: Maybe ActiveBar,
|
||||
_scDeltaX :: !Double,
|
||||
_scDeltaY :: !Double,
|
||||
_scChildSize :: Size,
|
||||
_scReqSize :: Tree SizeReq
|
||||
_sstDragging :: Maybe ActiveBar,
|
||||
_sstDeltaX :: !Double,
|
||||
_sstDeltaY :: !Double,
|
||||
_sstChildSize :: Size,
|
||||
_sstReqSize :: Tree SizeReq
|
||||
} deriving (Typeable)
|
||||
|
||||
newtype ScrollMessage = ScrollTo Rect deriving Typeable
|
||||
|
||||
data ScrollContext = ScrollContext {
|
||||
hScrollRatio :: Double,
|
||||
vScrollRatio :: Double,
|
||||
@ -51,14 +60,28 @@ data ScrollContext = ScrollContext {
|
||||
vThumbRect :: Rect
|
||||
}
|
||||
|
||||
defaultState = ScrollState Nothing 0 0 def (singleNode def)
|
||||
defaultScrollConfig = ScrollConfig {
|
||||
_scActiveBarColor = Just $ darkGray { _alpha = 0.4 },
|
||||
_scIdleBarColor = Nothing,
|
||||
_scActiveThumbColor = gray,
|
||||
_scIdleThumbColor = darkGray,
|
||||
_scBarThickness = 10,
|
||||
_scWheelRate = 10
|
||||
}
|
||||
|
||||
barThickness = 10
|
||||
stepSize = 50
|
||||
wheelRate = 10
|
||||
defaultState = ScrollState {
|
||||
_sstDragging = Nothing,
|
||||
_sstDeltaX = 0,
|
||||
_sstDeltaY = 0,
|
||||
_sstChildSize = def,
|
||||
_sstReqSize = singleNode def
|
||||
}
|
||||
|
||||
scroll :: WidgetInstance s e -> WidgetInstance s e
|
||||
scroll managedWidget = makeInstance (makeScroll defaultState) managedWidget
|
||||
scroll managedWidget = scroll_ defaultScrollConfig managedWidget
|
||||
|
||||
scroll_ :: ScrollConfig -> WidgetInstance s e -> WidgetInstance s e
|
||||
scroll_ config managedWidget = makeInstance (makeScroll config defaultState) managedWidget
|
||||
|
||||
makeInstance :: Widget s e -> WidgetInstance s e -> WidgetInstance s e
|
||||
makeInstance widget managedWidget = (defaultWidgetInstance "scroll" widget) {
|
||||
@ -66,8 +89,8 @@ makeInstance widget managedWidget = (defaultWidgetInstance "scroll" widget) {
|
||||
_instanceFocusable = False
|
||||
}
|
||||
|
||||
makeScroll :: ScrollState -> Widget s e
|
||||
makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
makeScroll :: ScrollConfig -> ScrollState -> Widget s e
|
||||
makeScroll config state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = containerMergeTrees merge,
|
||||
_widgetHandleEvent = containerHandleEvent handleEvent,
|
||||
@ -82,22 +105,22 @@ makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
merge wctx ctx oldState widgetInstance = resultWidget newInstance where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
newInstance = widgetInstance {
|
||||
_instanceWidget = makeScroll newState
|
||||
_instanceWidget = makeScroll config newState
|
||||
}
|
||||
|
||||
handleEvent wctx ctx evt widgetInstance = case evt of
|
||||
ButtonAction point btn status -> result where
|
||||
isLeftPressed = status == PressedBtn && btn == LeftBtn
|
||||
isButtonReleased = status == ReleasedBtn
|
||||
isDragging = isJust $ _scDragging state
|
||||
newState = if | isLeftPressed && hMouseInThumb && not isDragging -> state { _scDragging = Just HBar }
|
||||
| isLeftPressed && vMouseInThumb && not isDragging -> state { _scDragging = Just VBar }
|
||||
isDragging = isJust $ _sstDragging state
|
||||
newState = if | isLeftPressed && hMouseInThumb && not isDragging -> state { _sstDragging = Just HBar }
|
||||
| isLeftPressed && vMouseInThumb && not isDragging -> state { _sstDragging = Just VBar }
|
||||
| isButtonReleased && hMouseInScroll && not isDragging -> updateScrollThumb state HBar point viewport sctx
|
||||
| isButtonReleased && vMouseInScroll && not isDragging -> updateScrollThumb state VBar point viewport sctx
|
||||
| isButtonReleased -> state { _scDragging = Nothing }
|
||||
| isButtonReleased -> state { _sstDragging = Nothing }
|
||||
| otherwise -> state
|
||||
newInstance = widgetInstance {
|
||||
_instanceWidget = makeScroll newState
|
||||
_instanceWidget = makeScroll config newState
|
||||
}
|
||||
handledResult = Just $ resultReqs [IgnoreChildrenEvents] newInstance
|
||||
result = if | isLeftPressed && (hMouseInThumb || vMouseInThumb) -> handledResult
|
||||
@ -105,7 +128,7 @@ makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
| isButtonReleased && isDragging -> handledResult
|
||||
| otherwise -> Nothing
|
||||
Click point btn -> result where
|
||||
isDragging = isJust $ _scDragging state
|
||||
isDragging = isJust $ _sstDragging state
|
||||
handledResult = Just $ resultReqs [IgnoreChildrenEvents] widgetInstance
|
||||
result = if | hMouseInScroll || vMouseInScroll || isDragging -> handledResult
|
||||
| otherwise -> Nothing
|
||||
@ -117,17 +140,18 @@ makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
needsUpdate = (wx /= 0 && childWidth > vw) || (wy /= 0 && childHeight > vh)
|
||||
result = if | needsUpdate -> Just $ resultReqs [IgnoreChildrenEvents] (rebuildWidget wctx newState widgetInstance prevReqs)
|
||||
| otherwise -> Nothing
|
||||
wheelRate = _scWheelRate config
|
||||
stepX = wx * if wheelDirection == WheelNormal then -wheelRate else wheelRate
|
||||
stepY = wy * if wheelDirection == WheelNormal then wheelRate else -wheelRate
|
||||
newState = state {
|
||||
_scDeltaX = scrollAxis stepX dx childWidth vw,
|
||||
_scDeltaY = scrollAxis stepY dy childHeight vh
|
||||
_sstDeltaX = scrollAxis stepX dx childWidth vw,
|
||||
_sstDeltaY = scrollAxis stepY dy childHeight vh
|
||||
}
|
||||
_ -> Nothing
|
||||
where
|
||||
viewport = _instanceViewport widgetInstance
|
||||
Rect vx vy vw vh = _instanceViewport widgetInstance
|
||||
sctx@ScrollContext{..} = scrollStatus wctx state viewport
|
||||
sctx@ScrollContext{..} = scrollStatus config wctx state viewport
|
||||
|
||||
scrollAxis reqDelta currScroll childPos viewportLimit
|
||||
| reqDelta >= 0 = if currScroll + reqDelta < 0
|
||||
@ -158,8 +182,8 @@ makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
| abs diffT <= abs diffB -> diffT + dy
|
||||
| otherwise -> diffB + dy
|
||||
newState = state {
|
||||
_scDeltaX = scrollAxis stepX 0 childWidth vw,
|
||||
_scDeltaY = scrollAxis stepY 0 childHeight vh
|
||||
_sstDeltaX = scrollAxis stepX 0 childWidth vw,
|
||||
_sstDeltaY = scrollAxis stepY 0 childHeight vh
|
||||
}
|
||||
newInstance = rebuildWidget wctx newState widgetInstance prevReqs
|
||||
|
||||
@ -173,10 +197,10 @@ makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
vDelta = (ry - py + vMid) / vScrollRatio
|
||||
newDeltaX = if activeBar == HBar then scrollAxis hDelta 0 childWidth rw else dx
|
||||
newDeltaY = if activeBar == VBar then scrollAxis vDelta 0 childHeight rh else dy
|
||||
newState = state { _scDeltaX = newDeltaX, _scDeltaY = newDeltaY }
|
||||
newState = state { _sstDeltaX = newDeltaX, _sstDeltaY = newDeltaY }
|
||||
|
||||
rebuildWidget wctx newState widgetInstance reqs = newInstance where
|
||||
newWidget = makeScroll newState
|
||||
newWidget = makeScroll config newState
|
||||
tempInstance = widgetInstance { _instanceWidget = newWidget }
|
||||
newInstance = scrollResize (Just newWidget) wctx (_instanceViewport tempInstance) (_instanceRenderArea tempInstance) tempInstance reqs
|
||||
|
||||
@ -194,7 +218,7 @@ makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
areaH = max h childHeight2
|
||||
childRenderArea = Rect (l + dx) (t + dy) areaW areaH
|
||||
|
||||
newWidget = fromMaybe (makeScroll $ state { _scChildSize = Size areaW areaH, _scReqSize = reqs }) updatedWidget
|
||||
newWidget = fromMaybe (makeScroll config $ state { _sstChildSize = Size areaW areaH, _sstReqSize = reqs }) updatedWidget
|
||||
newChildWidget = _widgetResize (_instanceWidget child) wctx viewport childRenderArea child childReq
|
||||
|
||||
newInstance = widgetInstance {
|
||||
@ -210,29 +234,31 @@ makeScroll state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
containerRender defaultContainerRender renderer wctx ctx widgetInstance
|
||||
resetScissor renderer
|
||||
|
||||
when (hScrollRequired && hMouseInScroll) $
|
||||
drawRect renderer hScrollRect (Just barColor) Nothing
|
||||
|
||||
when (vScrollRequired && vMouseInScroll) $
|
||||
drawRect renderer vScrollRect (Just barColor) Nothing
|
||||
|
||||
when hScrollRequired $
|
||||
drawRect renderer hThumbRect (Just handleColorH) Nothing
|
||||
drawRect renderer hScrollRect barColorH Nothing
|
||||
|
||||
when vScrollRequired $
|
||||
drawRect renderer vThumbRect (Just handleColorV) Nothing
|
||||
drawRect renderer vScrollRect barColorV Nothing
|
||||
|
||||
when hScrollRequired $
|
||||
drawRect renderer hThumbRect (Just thumbColorH) Nothing
|
||||
|
||||
when vScrollRequired $
|
||||
drawRect renderer vThumbRect (Just thumbColorV) Nothing
|
||||
where
|
||||
viewport = _instanceViewport widgetInstance
|
||||
ScrollContext{..} = scrollStatus wctx state viewport
|
||||
barColor = darkGray { _alpha = 0.4 }
|
||||
draggingH = _scDragging state == Just HBar
|
||||
draggingV = _scDragging state == Just VBar
|
||||
handleColorH = if hMouseInThumb || draggingH then gray else darkGray
|
||||
handleColorV = if vMouseInThumb || draggingV then gray else darkGray
|
||||
ScrollContext{..} = scrollStatus config wctx state viewport
|
||||
draggingH = _sstDragging state == Just HBar
|
||||
draggingV = _sstDragging state == Just VBar
|
||||
barColorH = if hMouseInScroll then _scActiveBarColor config else _scIdleBarColor config
|
||||
barColorV = if vMouseInScroll then _scActiveBarColor config else _scIdleBarColor config
|
||||
thumbColorH = if hMouseInThumb || draggingH then _scActiveThumbColor config else _scIdleThumbColor config
|
||||
thumbColorV = if vMouseInThumb || draggingV then _scActiveThumbColor config else _scIdleThumbColor config
|
||||
|
||||
scrollStatus :: WidgetContext s e -> ScrollState -> Rect -> ScrollContext
|
||||
scrollStatus wctx scrollState viewport = ScrollContext{..} where
|
||||
scrollStatus :: ScrollConfig -> WidgetContext s e -> ScrollState -> Rect -> ScrollContext
|
||||
scrollStatus config wctx scrollState viewport = ScrollContext{..} where
|
||||
ScrollState _ dx dy (Size childWidth childHeight) _ = scrollState
|
||||
barThickness = _scBarThickness config
|
||||
mousePos = statusMousePos (_wcInputStatus wctx)
|
||||
vpLeft = _rx viewport
|
||||
vpTop = _ry viewport
|
||||
|
||||
8
tasks.md
8
tasks.md
@ -30,7 +30,7 @@
|
||||
- Reorganize drawing operations
|
||||
- Stop, think and design
|
||||
- How should all of this be organized?
|
||||
- How should modules be layed out?
|
||||
- How should modules be laid out?
|
||||
- What are good interfaces for the different parts of the system?
|
||||
- Does it make sense that handleEvent is the only pure function in a widget?
|
||||
- Based on the previous design, refactor modules
|
||||
@ -42,7 +42,7 @@
|
||||
- Check if resize children still makes sense (maybe the widget itself can resize on the corresponding event?)
|
||||
- Handle SetFocus request
|
||||
- Check if WidgetState is really needed
|
||||
- Maybe Data.Dynamic can be used, but currently abadoned
|
||||
- Maybe Data.Dynamic can be used, but currently abandoned
|
||||
- Rethink Tree.Path import
|
||||
- Clean up Seq imports
|
||||
- Where can we use Seq? Does it make sense to use it everywhere? What about Traversable?
|
||||
@ -108,12 +108,13 @@
|
||||
- Create nullable version which takes care of fmapping traversable with Just
|
||||
- Check why vstack fails when using [spacer, listView]
|
||||
- Remove status from Click event. Add ButtonPressed and ButtonReleased events
|
||||
- Change order of parameters. We should always pass _old_ before _new_
|
||||
|
||||
- Pending
|
||||
- Change order of parameters. We should always pass _old_ before _new_
|
||||
- Unify criteria for instantiation
|
||||
- Component name without underscore receives parameters positionally
|
||||
- Component name with underscore receives Config instance
|
||||
- Add renderer parameter to resize. It will be needed for auto adjustable Label and to handle ellipsis in text
|
||||
- Should Resize be restored?
|
||||
- Try to unify path handling on widgetFind and widgetNextFocusable
|
||||
- This is also needed for _widgetPreferredSize and _widgetResize
|
||||
@ -126,6 +127,7 @@
|
||||
- Add support for dashed borders
|
||||
- Create self rendered version of dropdown and list
|
||||
- Show listview in appropriate location (if dropdown is at bottom, the listView should be up)
|
||||
- Add config for Label to choose from: Overflow | Cut (better name?) | Ellipsis
|
||||
- Create Checkbox
|
||||
- Create Radio
|
||||
- Create Slider
|
||||
|
||||
Loading…
Reference in New Issue
Block a user