mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-21 00:38:01 +03:00
Format widgets
This commit is contained in:
Francisco Vallarino
parent
ad47f7f387
commit
7054a1d2a2
@ -6,6 +6,7 @@ module Monomer.Event.Keyboard (
|
||||
isKeyBackspace,
|
||||
isKeyEsc,
|
||||
isKeyReturn,
|
||||
isKeySpace,
|
||||
isKeyTab,
|
||||
isKeyLeft,
|
||||
isKeyRight,
|
||||
@ -55,27 +56,68 @@ convertKeyModifier keyMod = KeyMod {
|
||||
keyModAltGr = SDL.keyModifierAltGr keyMod
|
||||
}
|
||||
|
||||
keyBackspace :: KeyCode
|
||||
keyBackspace = getKeycode SDL.KeycodeBackspace
|
||||
|
||||
keyEsc :: KeyCode
|
||||
keyEsc = getKeycode SDL.KeycodeEscape
|
||||
|
||||
keyReturn :: KeyCode
|
||||
keyReturn = getKeycode SDL.KeycodeReturn
|
||||
|
||||
keySpace :: KeyCode
|
||||
keySpace = getKeycode SDL.KeycodeSpace
|
||||
|
||||
keyTab :: KeyCode
|
||||
keyTab = getKeycode SDL.KeycodeTab
|
||||
|
||||
keyLeft :: KeyCode
|
||||
keyLeft = getKeycode SDL.KeycodeLeft
|
||||
|
||||
keyRight :: KeyCode
|
||||
keyRight = getKeycode SDL.KeycodeRight
|
||||
|
||||
keyUp :: KeyCode
|
||||
keyUp = getKeycode SDL.KeycodeUp
|
||||
|
||||
keyDown :: KeyCode
|
||||
keyDown = getKeycode SDL.KeycodeDown
|
||||
|
||||
keyC :: KeyCode
|
||||
keyC = getKeycode SDL.KeycodeC
|
||||
|
||||
keyV :: KeyCode
|
||||
keyV = getKeycode SDL.KeycodeV
|
||||
|
||||
isKeyBackspace :: KeyCode -> Bool
|
||||
isKeyBackspace = (== keyBackspace)
|
||||
|
||||
isKeyEsc :: KeyCode -> Bool
|
||||
isKeyEsc = (== keyEsc)
|
||||
|
||||
isKeyReturn :: KeyCode -> Bool
|
||||
isKeyReturn = (== keyReturn)
|
||||
|
||||
isKeySpace :: KeyCode -> Bool
|
||||
isKeySpace = (== keySpace)
|
||||
|
||||
isKeyTab :: KeyCode -> Bool
|
||||
isKeyTab = (== keyTab)
|
||||
|
||||
isKeyLeft :: KeyCode -> Bool
|
||||
isKeyLeft = (== keyLeft)
|
||||
|
||||
isKeyRight :: KeyCode -> Bool
|
||||
isKeyRight = (== keyRight)
|
||||
|
||||
isKeyUp :: KeyCode -> Bool
|
||||
isKeyUp = (== keyUp)
|
||||
|
||||
isKeyDown :: KeyCode -> Bool
|
||||
isKeyDown = (== keyDown)
|
||||
|
||||
isKeyC :: KeyCode -> Bool
|
||||
isKeyC = (== keyC)
|
||||
|
||||
isKeyV :: KeyCode -> Bool
|
||||
isKeyV = (== keyV)
|
||||
|
||||
@ -7,6 +7,7 @@ import qualified Data.Map.Strict as M
|
||||
|
||||
import Monomer.Event.Types
|
||||
|
||||
defKeyMod :: KeyMod
|
||||
defKeyMod = KeyMod {
|
||||
keyModLeftShift = False,
|
||||
keyModRightShift = False,
|
||||
@ -21,6 +22,7 @@ defKeyMod = KeyMod {
|
||||
keyModAltGr = False
|
||||
}
|
||||
|
||||
defInputStatus :: InputStatus
|
||||
defInputStatus = InputStatus {
|
||||
statusMousePos = def,
|
||||
statusKeyMod = defKeyMod,
|
||||
|
||||
@ -37,24 +37,29 @@ button_ :: ButtonConfig s e -> WidgetInstance s e
|
||||
button_ config = defaultWidgetInstance "button" (makeButton config)
|
||||
|
||||
makeButton :: ButtonConfig s e -> Widget s e
|
||||
makeButton config = createWidget {
|
||||
makeButton config = widget where
|
||||
widget = createWidget {
|
||||
_widgetHandleEvent = handleEvent,
|
||||
_widgetPreferredSize = preferredSize,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
handleEvent wenv ctx evt widgetInst = case evt of
|
||||
Click (Point x y) _ -> Just $ resultReqsEvents requests events widgetInst where
|
||||
requests = _btnOnChangeReq config
|
||||
events = _btnOnChange config
|
||||
_ -> Nothing
|
||||
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText (_btnLabel config)
|
||||
sizeReq = SizeReq size FlexibleSize FlexibleSize
|
||||
handleEvent wenv ctx evt widgetInst = case evt of
|
||||
Click (Point x y) _ -> Just result where
|
||||
requests = _btnOnChangeReq config
|
||||
events = _btnOnChange config
|
||||
result = resultReqsEvents requests events widgetInst
|
||||
_ -> Nothing
|
||||
|
||||
render renderer wenv WidgetInstance{..} =
|
||||
do
|
||||
drawStyledBackground renderer _instanceRenderArea _instanceStyle
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle (_btnLabel config)
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText (_btnLabel config)
|
||||
sizeReq = SizeReq size FlexibleSize FlexibleSize
|
||||
|
||||
render renderer wenv WidgetInstance{..} = do
|
||||
drawStyledBackground renderer renderArea style
|
||||
drawStyledText_ renderer renderArea style (_btnLabel config)
|
||||
|
||||
where
|
||||
renderArea = _instanceRenderArea
|
||||
style = _instanceStyle
|
||||
|
||||
@ -31,7 +31,7 @@ containerConfig :: ContainerConfig s e
|
||||
containerConfig = ContainerConfig [] []
|
||||
|
||||
container :: ContainerConfig s e -> WidgetInstance s e -> WidgetInstance s e
|
||||
container config managedWidget = makeInstance (makeContainer config) managedWidget
|
||||
container config managed = makeInstance (makeContainer config) managed
|
||||
|
||||
makeInstance :: Widget s e -> WidgetInstance s e -> WidgetInstance s e
|
||||
makeInstance widget managedWidget = (defaultWidgetInstance "container" widget) {
|
||||
@ -40,34 +40,38 @@ makeInstance widget managedWidget = (defaultWidgetInstance "container" widget) {
|
||||
}
|
||||
|
||||
makeContainer :: ContainerConfig s e -> Widget s e
|
||||
makeContainer config = createContainer {
|
||||
makeContainer config = widget where
|
||||
widget = createContainer {
|
||||
_widgetHandleEvent = containerHandleEvent handleEvent,
|
||||
_widgetPreferredSize = containerPreferredSize preferredSize,
|
||||
_widgetResize = containerResize resize,
|
||||
_widgetRender = containerRender render
|
||||
}
|
||||
where
|
||||
handleEvent wenv ctx evt widgetInst = case evt of
|
||||
Click point btn -> result where
|
||||
events = _ctOnClick config
|
||||
requests = _ctOnClickReq config
|
||||
result = if btn == LeftBtn && not (null events && null requests)
|
||||
then Just $ resultReqsEvents requests events widgetInst
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
sizeReq = nodeValue $ Seq.index reqs 0
|
||||
handleEvent wenv ctx evt widgetInst = case evt of
|
||||
Click point btn -> result where
|
||||
events = _ctOnClick config
|
||||
requests = _ctOnClickReq config
|
||||
needsUpdate = btn == LeftBtn && not (null events && null requests)
|
||||
result
|
||||
| needsUpdate = Just $ resultReqsEvents requests events widgetInst
|
||||
| otherwise = Nothing
|
||||
_ -> Nothing
|
||||
|
||||
resize wenv viewport renderArea widgetInst children reqs = (widgetInst, assignedArea) where
|
||||
assignedArea = Seq.singleton (viewport, renderArea)
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
sizeReq = nodeValue $ Seq.index reqs 0
|
||||
|
||||
render renderer wenv widgetInst = do
|
||||
let point = statusMousePos (_weInputStatus wenv)
|
||||
let viewport = _instanceViewport widgetInst
|
||||
let Style{..} = _instanceStyle widgetInst
|
||||
resize wenv viewport renderArea widgetInst children reqs = resized where
|
||||
assignedArea = Seq.singleton (viewport, renderArea)
|
||||
resized = (widgetInst, assignedArea)
|
||||
|
||||
drawRect renderer viewport _styleColor Nothing
|
||||
render renderer wenv widgetInst = do
|
||||
drawRect renderer viewport _styleColor Nothing
|
||||
|
||||
when (pointInRect point viewport) $
|
||||
drawRect renderer viewport _styleHover Nothing
|
||||
when (pointInRect point viewport) $
|
||||
drawRect renderer viewport _styleHover Nothing
|
||||
|
||||
where
|
||||
point = statusMousePos (_weInputStatus wenv)
|
||||
viewport = _instanceViewport widgetInst
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
|
||||
@ -55,7 +55,8 @@ newtype DropdownState = DropdownState {
|
||||
|
||||
newtype DropdownMessage = OnChangeMessage Int deriving Typeable
|
||||
|
||||
dropdownConfig :: WidgetValue s a -> Seq a -> (a -> Text) -> DropdownConfig s e a
|
||||
dropdownConfig
|
||||
:: WidgetValue s a -> Seq a -> (a -> Text) -> DropdownConfig s e a
|
||||
dropdownConfig value items itemToText = DropdownConfig {
|
||||
_ddValue = value,
|
||||
_ddItems = items,
|
||||
@ -67,7 +68,9 @@ dropdownConfig value items itemToText = DropdownConfig {
|
||||
_ddHoverColor = lightGray
|
||||
}
|
||||
|
||||
dropdown :: (Traversable t, Eq a) => ALens' s a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
dropdown
|
||||
:: (Traversable t, Eq a)
|
||||
=> ALens' s a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
dropdown field items itemToText = dropdown_ config where
|
||||
config = dropdownConfig (WidgetLens field) newItems itemToText
|
||||
newItems = foldl' (|>) Empty items
|
||||
@ -82,7 +85,8 @@ makeInstance widget = (defaultWidgetInstance "dropdown" widget) {
|
||||
}
|
||||
|
||||
makeDropdown :: (Eq a) => DropdownConfig s e a -> DropdownState -> Widget s e
|
||||
makeDropdown config state = createContainer {
|
||||
makeDropdown config state = widget where
|
||||
widget = createContainer {
|
||||
_widgetInit = containerInit init,
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = containerMergeTrees merge,
|
||||
@ -92,102 +96,112 @@ makeDropdown config state = createContainer {
|
||||
_widgetResize = containerResize resize,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
isOpen = _isOpen state
|
||||
currentValue wenv = widgetValueGet (_weModel wenv) (_ddValue config)
|
||||
|
||||
createDropdown wenv newState widgetInst = newInstance where
|
||||
selected = currentValue wenv
|
||||
path = _instancePath widgetInst
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeDropdown config newState,
|
||||
_instanceChildren = Seq.singleton $ makeListView config path selected
|
||||
}
|
||||
isOpen = _isOpen state
|
||||
currentValue wenv = widgetValueGet (_weModel wenv) (_ddValue config)
|
||||
|
||||
init wenv widgetInst = resultWidget $ createDropdown wenv state widgetInst
|
||||
createDropdown wenv newState widgetInst = newInstance where
|
||||
selected = currentValue wenv
|
||||
path = _instancePath widgetInst
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeDropdown config newState,
|
||||
_instanceChildren = Seq.singleton $ makeListView config path selected
|
||||
}
|
||||
|
||||
merge wenv oldState newInstance = resultWidget $ createDropdown wenv newState newInstance where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
init wenv widgetInst = resultWidget $ createDropdown wenv state widgetInst
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
Click point _
|
||||
| openRequired point widgetInst -> Just $ handleOpenDropdown wenv widgetInst
|
||||
| closeRequired point widgetInst -> Just $ handleCloseDropdown wenv widgetInst
|
||||
KeyAction mode code status
|
||||
| isKeyDown code && not isOpen -> Just $ handleOpenDropdown wenv widgetInst
|
||||
| isKeyEsc code && isOpen -> Just $ handleCloseDropdown wenv widgetInst
|
||||
_
|
||||
| not isOpen -> Just $ resultReqs [IgnoreChildrenEvents] widgetInst
|
||||
| otherwise -> Nothing
|
||||
merge wenv oldState newInst = result where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
result = resultWidget $ createDropdown wenv newState newInst
|
||||
|
||||
openRequired point widgetInst = not isOpen && inViewport where
|
||||
inViewport = pointInRect point (_instanceViewport widgetInst)
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
Click point _
|
||||
| openRequired point widgetInst -> Just $ openDropdown wenv widgetInst
|
||||
| closeRequired point widgetInst -> Just $ closeDropdown wenv widgetInst
|
||||
KeyAction mode code status
|
||||
| isKeyDown code && not isOpen -> Just $ openDropdown wenv widgetInst
|
||||
| isKeyEsc code && isOpen -> Just $ closeDropdown wenv widgetInst
|
||||
_
|
||||
| not isOpen -> Just $ resultReqs [IgnoreChildrenEvents] widgetInst
|
||||
| otherwise -> Nothing
|
||||
|
||||
closeRequired point widgetInst = isOpen && not inOverlay where
|
||||
inOverlay = case Seq.lookup 0 (_instanceChildren widgetInst) of
|
||||
Just inst -> pointInRect point (_instanceViewport inst)
|
||||
Nothing -> False
|
||||
openRequired point widgetInst = not isOpen && inViewport where
|
||||
inViewport = pointInRect point (_instanceViewport widgetInst)
|
||||
|
||||
handleOpenDropdown wenv widgetInst = resultReqs requests newInstance where
|
||||
selected = currentValue wenv
|
||||
selectedIdx = fromMaybe 0 (Seq.elemIndexL selected (_ddItems config))
|
||||
newState = DropdownState True
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeDropdown config newState
|
||||
}
|
||||
path = _instancePath widgetInst
|
||||
lvPath = firstChildPath widgetInst
|
||||
requests = [SetOverlay path, SetFocus lvPath]
|
||||
closeRequired point widgetInst = isOpen && not inOverlay where
|
||||
inOverlay = case Seq.lookup 0 (_instanceChildren widgetInst) of
|
||||
Just inst -> pointInRect point (_instanceViewport inst)
|
||||
Nothing -> False
|
||||
|
||||
handleCloseDropdown wenv widgetInst = resultReqs requests newInstance where
|
||||
path = _instancePath widgetInst
|
||||
newState = DropdownState False
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeDropdown config newState
|
||||
}
|
||||
requests = [ResetOverlay, SetFocus path]
|
||||
openDropdown wenv widgetInst = resultReqs requests newInstance where
|
||||
selected = currentValue wenv
|
||||
selectedIdx = fromMaybe 0 (Seq.elemIndexL selected (_ddItems config))
|
||||
newState = DropdownState True
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeDropdown config newState
|
||||
}
|
||||
path = _instancePath widgetInst
|
||||
lvPath = firstChildPath widgetInst
|
||||
requests = [SetOverlay path, SetFocus lvPath]
|
||||
|
||||
handleMessage wenv target message widgetInst = cast message
|
||||
>>= \(OnChangeMessage idx) -> Seq.lookup idx (_ddItems config)
|
||||
>>= \value -> Just $ handleOnChange wenv idx value widgetInst
|
||||
closeDropdown wenv widgetInst = resultReqs requests newInstance where
|
||||
path = _instancePath widgetInst
|
||||
newState = DropdownState False
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeDropdown config newState
|
||||
}
|
||||
requests = [ResetOverlay, SetFocus path]
|
||||
|
||||
handleOnChange wenv idx item widgetInst = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance where
|
||||
WidgetResult reqs events newInstance = handleCloseDropdown wenv widgetInst
|
||||
newReqs = Seq.fromList $ widgetValueSet (_ddValue config) item
|
||||
newEvents = Seq.fromList $ fmap ($ item) (_ddOnChange config)
|
||||
handleMessage wenv target message widgetInst = cast message
|
||||
>>= \(OnChangeMessage idx) -> Seq.lookup idx (_ddItems config)
|
||||
>>= \value -> Just $ onChange wenv idx value widgetInst
|
||||
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText (dropdownLabel wenv)
|
||||
sizeReq = SizeReq size FlexibleSize StrictSize
|
||||
onChange wenv idx item widgetInst = result where
|
||||
WidgetResult reqs events newInstance = closeDropdown wenv widgetInst
|
||||
newReqs = Seq.fromList $ widgetValueSet (_ddValue config) item
|
||||
newEvents = Seq.fromList $ fmap ($ item) (_ddOnChange config)
|
||||
result = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance
|
||||
|
||||
resize wenv viewport renderArea widgetInst children reqs = (widgetInst, assignedArea) where
|
||||
childrenReqs = Seq.zip children reqs
|
||||
area = case Seq.lookup 0 childrenReqs of
|
||||
Just (child, reqChild) -> (oViewport, oRenderArea) where
|
||||
reqHeight = _h . _sizeRequested . nodeValue $ reqChild
|
||||
maxHeight = min reqHeight 150
|
||||
oViewport = viewport { _ry = _ry viewport + _rh viewport, _rh = maxHeight }
|
||||
oRenderArea = renderArea { _ry = _ry renderArea + _rh viewport }
|
||||
Nothing -> (viewport, renderArea)
|
||||
assignedArea = Seq.singleton area
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText (dropdownLabel wenv)
|
||||
sizeReq = SizeReq size FlexibleSize StrictSize
|
||||
|
||||
render renderer wenv WidgetInstance{..} =
|
||||
do
|
||||
drawStyledBackground renderer _instanceRenderArea _instanceStyle
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle (dropdownLabel wenv)
|
||||
resize wenv viewport renderArea widgetInst children reqs = resized where
|
||||
childrenReqs = Seq.zip children reqs
|
||||
area = case Seq.lookup 0 childrenReqs of
|
||||
Just (child, reqChild) -> (oViewport, oRenderArea) where
|
||||
reqHeight = _h . _sizeRequested . nodeValue $ reqChild
|
||||
maxHeight = min reqHeight 150
|
||||
oViewport = viewport {
|
||||
_ry = _ry viewport + _rh viewport,
|
||||
_rh = maxHeight
|
||||
}
|
||||
oRenderArea = renderArea { _ry = _ry renderArea + _rh viewport }
|
||||
Nothing -> (viewport, renderArea)
|
||||
assignedArea = Seq.singleton area
|
||||
resized = (widgetInst, assignedArea)
|
||||
|
||||
when (isOpen && isJust listViewOverlay) $
|
||||
createOverlay renderer $ renderOverlay renderer wenv (fromJust listViewOverlay)
|
||||
where
|
||||
listViewOverlay = Seq.lookup 0 _instanceChildren
|
||||
render renderer wenv WidgetInstance{..} = do
|
||||
drawStyledBackground renderer renderArea style
|
||||
drawStyledText_ renderer renderArea style (dropdownLabel wenv)
|
||||
|
||||
renderOverlay renderer wenv overlayInstance = renderAction where
|
||||
renderAction = _widgetRender (_instanceWidget overlayInstance) renderer wenv overlayInstance
|
||||
when (isOpen && isJust listViewOverlay) $
|
||||
createOverlay renderer $
|
||||
renderOverlay renderer wenv (fromJust listViewOverlay)
|
||||
where
|
||||
listViewOverlay = Seq.lookup 0 _instanceChildren
|
||||
renderArea = _instanceRenderArea
|
||||
style = _instanceStyle
|
||||
|
||||
dropdownLabel wenv = _ddItemToText config $ currentValue wenv
|
||||
renderOverlay renderer wenv overlayInstance = renderAction where
|
||||
widget = _instanceWidget overlayInstance
|
||||
renderAction = _widgetRender widget renderer wenv overlayInstance
|
||||
|
||||
makeListView :: (Eq a) => DropdownConfig s e a -> Path -> a -> WidgetInstance s e
|
||||
dropdownLabel wenv = _ddItemToText config $ currentValue wenv
|
||||
|
||||
makeListView
|
||||
:: (Eq a) => DropdownConfig s e a -> Path -> a -> WidgetInstance s e
|
||||
makeListView DropdownConfig{..} dropdownPath selected = listView_ lvConfig where
|
||||
lvConfig = ListViewConfig {
|
||||
_lvValue = WidgetValue selected,
|
||||
|
||||
@ -27,32 +27,46 @@ vgrid children = (defaultWidgetInstance "vgrid" (makeFixedGrid False)) {
|
||||
}
|
||||
|
||||
makeFixedGrid :: Bool -> Widget s e
|
||||
makeFixedGrid isHorizontal = createContainer {
|
||||
makeFixedGrid isHorizontal = widget where
|
||||
widget = createContainer {
|
||||
_widgetPreferredSize = containerPreferredSize preferredSize,
|
||||
_widgetResize = containerResize resize
|
||||
}
|
||||
where
|
||||
preferredSize wenv widgetInst children reqs = Node reqSize reqs where
|
||||
(vchildren, vreqs) = visibleChildrenReq children reqs
|
||||
reqSize = SizeReq (Size width height) FlexibleSize FlexibleSize
|
||||
width = if Seq.null vchildren then 0 else fromIntegral wMul * (maximum . fmap (_w . _sizeRequested)) vreqs
|
||||
height = if Seq.null vchildren then 0 else fromIntegral hMul * (maximum . fmap (_h . _sizeRequested)) vreqs
|
||||
wMul = if isHorizontal then length vchildren else 1
|
||||
hMul = if isHorizontal then 1 else length vchildren
|
||||
|
||||
resize wenv viewport renderArea widgetInst children reqs = (widgetInst, assignedAreas) where
|
||||
vchildren = Seq.filter _instanceVisible children
|
||||
Rect l t w h = renderArea
|
||||
cols = if isHorizontal then length vchildren else 1
|
||||
rows = if isHorizontal then 1 else length vchildren
|
||||
foldHelper (newAreas, index) child = (newAreas |> newArea, newIndex) where
|
||||
visible = _instanceVisible child
|
||||
newIndex = index + if _instanceVisible child then 1 else 0
|
||||
newViewport = if visible then calcViewport index else def
|
||||
newArea = (newViewport, newViewport)
|
||||
assignedAreas = fst $ foldl' foldHelper (Seq.empty, 0) vchildren
|
||||
calcViewport i = Rect (cx i) (cy i) cw ch
|
||||
cw = if cols > 0 then w / fromIntegral cols else 0
|
||||
ch = if rows > 0 then h / fromIntegral rows else 0
|
||||
cx i = if rows > 0 then l + fromIntegral (i `div` rows) * cw else 0
|
||||
cy i = if cols > 0 then t + fromIntegral (i `div` cols) * ch else 0
|
||||
preferredSize wenv widgetInst children reqs = Node reqSize reqs where
|
||||
(vchildren, vreqs) = visibleChildrenReq children reqs
|
||||
reqSize = SizeReq (Size width height) FlexibleSize FlexibleSize
|
||||
width
|
||||
| Seq.null vchildren = 0
|
||||
| otherwise = wMul * (maximum . fmap (_w . _sizeRequested)) vreqs
|
||||
height
|
||||
| Seq.null vchildren = 0
|
||||
| otherwise = hMul * (maximum . fmap (_h . _sizeRequested)) vreqs
|
||||
wMul
|
||||
| isHorizontal = fromIntegral (length vchildren)
|
||||
| otherwise = 1
|
||||
hMul
|
||||
| isHorizontal = 1
|
||||
| otherwise = fromIntegral (length vchildren)
|
||||
|
||||
resize wenv viewport renderArea widgetInst children reqs = resized where
|
||||
Rect l t w h = renderArea
|
||||
vchildren = Seq.filter _instanceVisible children
|
||||
cols = if isHorizontal then length vchildren else 1
|
||||
rows = if isHorizontal then 1 else length vchildren
|
||||
cw = if cols > 0 then w / fromIntegral cols else 0
|
||||
ch = if rows > 0 then h / fromIntegral rows else 0
|
||||
cx i
|
||||
| rows > 0 = l + fromIntegral (i `div` rows) * cw
|
||||
| otherwise = 0
|
||||
cy i
|
||||
| cols > 0 = t + fromIntegral (i `div` cols) * ch
|
||||
| otherwise = 0
|
||||
foldHelper (newAreas, index) child = (newAreas |> newArea, newIndex) where
|
||||
visible = _instanceVisible child
|
||||
newIndex = index + if _instanceVisible child then 1 else 0
|
||||
newViewport = if visible then calcViewport index else def
|
||||
newArea = (newViewport, newViewport)
|
||||
calcViewport i = Rect (cx i) (cy i) cw ch
|
||||
assignedAreas = fst $ foldl' foldHelper (Seq.empty, 0) vchildren
|
||||
resized = (widgetInst, assignedAreas)
|
||||
|
||||
@ -17,17 +17,17 @@ label :: Text -> WidgetInstance s e
|
||||
label caption = defaultWidgetInstance "label" (makeLabel caption)
|
||||
|
||||
makeLabel :: Text -> Widget s e
|
||||
makeLabel caption = createWidget {
|
||||
makeLabel caption = widget where
|
||||
widget = createWidget {
|
||||
_widgetPreferredSize = preferredSize,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText caption
|
||||
sizeReq = SizeReq size FlexibleSize StrictSize
|
||||
|
||||
render renderer wenv WidgetInstance{..} =
|
||||
do
|
||||
drawStyledBackground renderer _instanceRenderArea _instanceStyle
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle caption
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText caption
|
||||
sizeReq = SizeReq size FlexibleSize StrictSize
|
||||
|
||||
render renderer wenv WidgetInstance{..} = do
|
||||
drawStyledBackground renderer _instanceRenderArea _instanceStyle
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle caption
|
||||
|
||||
@ -60,7 +60,8 @@ newtype ListViewState = ListViewState {
|
||||
|
||||
newtype ListViewMessage = OnClickMessage Int deriving Typeable
|
||||
|
||||
listViewConfig :: WidgetValue s a -> Seq a -> (a -> Text) -> ListViewConfig s e a
|
||||
listViewConfig
|
||||
:: WidgetValue s a -> Seq a -> (a -> Text) -> ListViewConfig s e a
|
||||
listViewConfig value items itemToText = ListViewConfig {
|
||||
_lvValue = value,
|
||||
_lvItems = items,
|
||||
@ -72,7 +73,9 @@ listViewConfig value items itemToText = ListViewConfig {
|
||||
_lvHoverColor = lightGray
|
||||
}
|
||||
|
||||
listView :: (Traversable t, Eq a) => ALens' s a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
listView
|
||||
:: (Traversable t, Eq a)
|
||||
=> ALens' s a -> t a -> (a -> Text) -> WidgetInstance s e
|
||||
listView field items itemToText = listView_ config where
|
||||
config = listViewConfig (WidgetLens field) newItems itemToText
|
||||
newItems = foldl' (|>) Empty items
|
||||
@ -87,7 +90,8 @@ makeInstance widget = (defaultWidgetInstance "listView" widget) {
|
||||
}
|
||||
|
||||
makeListView :: (Eq a) => ListViewConfig s e a -> ListViewState -> Widget s e
|
||||
makeListView config state = createContainer {
|
||||
makeListView config state = widget where
|
||||
widget = createContainer {
|
||||
_widgetInit = containerInit init,
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = containerMergeTrees merge,
|
||||
@ -96,89 +100,106 @@ makeListView config state = createContainer {
|
||||
_widgetPreferredSize = containerPreferredSize preferredSize,
|
||||
_widgetResize = containerResize resize
|
||||
}
|
||||
where
|
||||
currentValue wenv = widgetValueGet (_weModel wenv) (_lvValue config)
|
||||
|
||||
createListView wenv newState widgetInst = newInstance where
|
||||
selected = currentValue wenv
|
||||
path = _instancePath widgetInst
|
||||
itemsList = makeItemsList config path selected (_highlighted newState)
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeListView config newState,
|
||||
_instanceChildren = Seq.singleton (scroll itemsList)
|
||||
}
|
||||
currentValue wenv = widgetValueGet (_weModel wenv) (_lvValue config)
|
||||
|
||||
init wenv widgetInst = resultWidget $ createListView wenv state widgetInst
|
||||
createListView wenv newState widgetInst = newInstance where
|
||||
selected = currentValue wenv
|
||||
path = _instancePath widgetInst
|
||||
itemsList = makeItemsList config path selected (_highlighted newState)
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeListView config newState,
|
||||
_instanceChildren = Seq.singleton (scroll itemsList)
|
||||
}
|
||||
|
||||
merge wenv oldState newInstance = resultWidget $ createListView wenv newState newInstance where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
init wenv widgetInst = resultWidget $ createListView wenv state widgetInst
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
KeyAction mode code status
|
||||
| isKeyDown code && status == KeyPressed -> handleHighlightNext wenv widgetInst
|
||||
| isKeyUp code && status == KeyPressed -> handleHighlightPrev wenv widgetInst
|
||||
| isKeyReturn code && status == KeyPressed -> Just $ selectItem wenv widgetInst (_highlighted state)
|
||||
_ -> Nothing
|
||||
merge wenv oldState newInstance = result where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
result = resultWidget $ createListView wenv newState newInstance
|
||||
|
||||
handleHighlightNext wenv widgetInst = highlightItem wenv widgetInst nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
nextIdx = if tempIdx < length (_lvItems config) - 1 then tempIdx + 1 else tempIdx
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
KeyAction mode code status
|
||||
| isKeyDown code && status == KeyPressed -> highlightNext wenv widgetInst
|
||||
| isKeyUp code && status == KeyPressed -> highlightPrev wenv widgetInst
|
||||
| isSelectKey code && status == KeyPressed -> resultSelected
|
||||
where
|
||||
resultSelected = Just $ selectItem wenv widgetInst (_highlighted state)
|
||||
isSelectKey code = isKeyReturn code || isKeySpace code
|
||||
_ -> Nothing
|
||||
|
||||
handleHighlightPrev wenv widgetInst = highlightItem wenv widgetInst nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
nextIdx = if tempIdx > 0 then tempIdx - 1 else tempIdx
|
||||
highlightNext wenv widgetInst = highlightItem wenv widgetInst nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
nextIdx
|
||||
| tempIdx < length (_lvItems config) - 1 = tempIdx + 1
|
||||
| otherwise = tempIdx
|
||||
|
||||
handleMessage wenv target message widgetInst = fmap handleSelect (cast message) where
|
||||
handleSelect (OnClickMessage idx) = selectItem wenv widgetInst idx
|
||||
highlightPrev wenv widgetInst = highlightItem wenv widgetInst nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
nextIdx
|
||||
| tempIdx > 0 = tempIdx - 1
|
||||
| otherwise = tempIdx
|
||||
|
||||
highlightItem wenv widgetInst nextIdx = Just $ widgetResult { _resultRequests = requests } where
|
||||
newState = ListViewState nextIdx
|
||||
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 = widgetInst {
|
||||
_instanceWidget = newWidget
|
||||
}
|
||||
-- ListView's tree will be rebuilt in merge, before merging its children, so it does not matter what we currently have
|
||||
newInstance = oldInstance
|
||||
widgetResult = _widgetMerge newWidget wenv oldInstance newInstance
|
||||
scrollToReq = itemScrollTo widgetInst nextIdx
|
||||
requests = Seq.fromList scrollToReq
|
||||
handleMessage wenv target message widgetInst = result where
|
||||
handleSelect (OnClickMessage idx) = selectItem wenv widgetInst idx
|
||||
result = fmap handleSelect (cast message)
|
||||
|
||||
selectItem wenv widgetInst idx = resultReqs requests newInstance where
|
||||
selected = currentValue wenv
|
||||
value = fromMaybe selected (Seq.lookup idx (_lvItems config))
|
||||
valueSetReq = widgetValueSet (_lvValue config) value
|
||||
scrollToReq = itemScrollTo widgetInst idx
|
||||
changeReqs = fmap ($ idx) (_lvOnChangeReq config)
|
||||
focusReq = [SetFocus $ _instancePath widgetInst]
|
||||
requests = valueSetReq ++ scrollToReq ++ changeReqs ++ focusReq
|
||||
newState = ListViewState idx
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeListView config newState
|
||||
}
|
||||
highlightItem wenv widgetInst nextIdx = result where
|
||||
newState = ListViewState nextIdx
|
||||
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 = widgetInst {
|
||||
_instanceWidget = newWidget
|
||||
}
|
||||
-- ListView's tree will be rebuilt in merge, before merging its children,
|
||||
-- so it does not matter what we currently have
|
||||
newInstance = oldInstance
|
||||
widgetResult = _widgetMerge newWidget wenv oldInstance newInstance
|
||||
scrollToReq = itemScrollTo widgetInst nextIdx
|
||||
requests = Seq.fromList scrollToReq
|
||||
result = Just $ widgetResult { _resultRequests = requests }
|
||||
|
||||
itemScrollTo widgetInst idx = maybeToList (fmap makeScrollReq renderArea) where
|
||||
lookup idx inst = Seq.lookup idx (_instanceChildren inst)
|
||||
renderArea = fmap _instanceRenderArea $ pure widgetInst
|
||||
>>= lookup 0 -- scroll
|
||||
>>= lookup 0 -- vstack
|
||||
>>= lookup idx -- item
|
||||
scrollPath = firstChildPath widgetInst
|
||||
makeScrollReq rect = SendMessage scrollPath (ScrollTo rect)
|
||||
selectItem wenv widgetInst idx = resultReqs requests newInstance where
|
||||
selected = currentValue wenv
|
||||
value = fromMaybe selected (Seq.lookup idx (_lvItems config))
|
||||
valueSetReq = widgetValueSet (_lvValue config) value
|
||||
scrollToReq = itemScrollTo widgetInst idx
|
||||
changeReqs = fmap ($ idx) (_lvOnChangeReq config)
|
||||
focusReq = [SetFocus $ _instancePath widgetInst]
|
||||
requests = valueSetReq ++ scrollToReq ++ changeReqs ++ focusReq
|
||||
newState = ListViewState idx
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeListView config newState
|
||||
}
|
||||
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
sizeReq = nodeValue $ Seq.index reqs 0
|
||||
itemScrollTo widgetInst idx = maybeToList (fmap scrollReq renderArea) where
|
||||
lookup idx inst = Seq.lookup idx (_instanceChildren inst)
|
||||
renderArea = fmap _instanceRenderArea $ pure widgetInst
|
||||
>>= lookup 0 -- scroll
|
||||
>>= lookup 0 -- vstack
|
||||
>>= lookup idx -- item
|
||||
scrollPath = firstChildPath widgetInst
|
||||
scrollReq rect = SendMessage scrollPath (ScrollTo rect)
|
||||
|
||||
resize wenv viewport renderArea widgetInst children reqs = (widgetInst, assignedArea) where
|
||||
assignedArea = Seq.singleton (viewport, renderArea)
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
sizeReq = nodeValue $ Seq.index reqs 0
|
||||
|
||||
makeItemsList :: (Eq a) => ListViewConfig s e a -> Path -> a -> Int -> WidgetInstance s e
|
||||
makeItemsList lvConfig lvPath selected highlightedIdx = makeItemsList where
|
||||
resize wenv viewport renderArea widgetInst children reqs = resized where
|
||||
assignedArea = Seq.singleton (viewport, renderArea)
|
||||
resized = (widgetInst, assignedArea)
|
||||
|
||||
makeItemsList
|
||||
:: (Eq a) => ListViewConfig s e a -> Path -> a -> Int -> WidgetInstance s e
|
||||
makeItemsList lvConfig lvPath selected highlightedIdx = itemsList where
|
||||
ListViewConfig{..} = lvConfig
|
||||
isSelected item = item == selected
|
||||
selectedColor item = if isSelected item then Just _lvSelectedColor else Nothing
|
||||
highlightedColor idx = if idx == highlightedIdx then Just _lvHighlightedColor else Nothing
|
||||
pairs = Seq.zip (Seq.fromList [0..length _lvItems]) _lvItems
|
||||
selectedColor item
|
||||
| isSelected item = Just _lvSelectedColor
|
||||
| otherwise = Nothing
|
||||
highlightedColor idx
|
||||
| idx == highlightedIdx = Just _lvHighlightedColor
|
||||
| otherwise = Nothing
|
||||
itemStyle idx item = def {
|
||||
_styleColor = selectedColor item <|> highlightedColor idx,
|
||||
_styleHover = Just _lvHoverColor
|
||||
@ -189,4 +210,5 @@ makeItemsList lvConfig lvPath selected highlightedIdx = makeItemsList where
|
||||
makeItem idx item = container config content `style` itemStyle idx item where
|
||||
config = itemConfig idx
|
||||
content = label (_lvItemToText item)
|
||||
makeItemsList = vstack $ fmap (uncurry makeItem) pairs
|
||||
pairs = Seq.zip (Seq.fromList [0..length _lvItems]) _lvItems
|
||||
itemsList = vstack $ fmap (uncurry makeItem) pairs
|
||||
|
||||
@ -18,7 +18,11 @@ import Monomer.Widget.BaseWidget
|
||||
import Monomer.Widget.Types
|
||||
import Monomer.Widget.Util
|
||||
|
||||
data SandboxData = SandboxData | SandboxData2 deriving (Eq, Show, Typeable)
|
||||
data SandboxData
|
||||
= SandboxData
|
||||
| SandboxData2
|
||||
deriving (Eq, Show, Typeable)
|
||||
|
||||
newtype SandboxState = SandboxState {
|
||||
_clickCount :: Int
|
||||
} deriving (Eq, Show, Typeable)
|
||||
@ -30,7 +34,8 @@ makeInstance :: Widget s e -> WidgetInstance s e
|
||||
makeInstance widget = defaultWidgetInstance "sandbox" widget
|
||||
|
||||
makeSandbox :: e -> SandboxState -> Widget s e
|
||||
makeSandbox onClick state = createWidget {
|
||||
makeSandbox onClick state = widget where
|
||||
widget = createWidget {
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = widgetMerge merge,
|
||||
_widgetHandleEvent = handleEvent,
|
||||
@ -38,38 +43,40 @@ makeSandbox onClick state = createWidget {
|
||||
_widgetPreferredSize = preferredSize,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
label = "Sandbox: " ++ show (_clickCount state)
|
||||
|
||||
merge wenv oldState widgetInst = resultWidget newInstance where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeSandbox onClick newState
|
||||
}
|
||||
label = "Sandbox: " ++ show (_clickCount state)
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
Click (Point x y) _ -> Just $ resultReqsEvents requests events newInstance where
|
||||
events = [onClick]
|
||||
requests = [RunTask (_instancePath widgetInst) runTask]
|
||||
newState = SandboxState (_clickCount state + 1)
|
||||
newInstance = makeInstance $ makeSandbox onClick newState
|
||||
Enter p -> Nothing --trace ("Enter: " ++ show p) Nothing
|
||||
Move p -> Nothing --trace ("Move: " ++ show p) Nothing
|
||||
Leave _ p -> Nothing --trace ("Leave: " ++ show p) Nothing
|
||||
_ -> Nothing
|
||||
merge wenv oldState widgetInst = resultWidget newInstance where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeSandbox onClick newState
|
||||
}
|
||||
|
||||
runTask = return SandboxData2
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
Click (Point x y) _ -> result where
|
||||
events = [onClick]
|
||||
requests = [RunTask (_instancePath widgetInst) runTask]
|
||||
newState = SandboxState (_clickCount state + 1)
|
||||
newInstance = makeInstance $ makeSandbox onClick newState
|
||||
result = Just $ resultReqsEvents requests events newInstance
|
||||
Enter p -> Nothing --trace ("Enter: " ++ show p) Nothing
|
||||
Move p -> Nothing --trace ("Move: " ++ show p) Nothing
|
||||
Leave _ p -> Nothing --trace ("Leave: " ++ show p) Nothing
|
||||
_ -> Nothing
|
||||
|
||||
handleMessage wenv target bd widgetInst = case cast bd of
|
||||
Just val -> if val == SandboxData2 then trace "Sandbox handleMessage called" Nothing else Nothing
|
||||
Nothing -> Nothing
|
||||
runTask = return SandboxData2
|
||||
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText (T.pack label)
|
||||
sizeReq = SizeReq size FlexibleSize FlexibleSize
|
||||
handleMessage wenv target bd widgetInst = case cast bd of
|
||||
Just val
|
||||
| val == SandboxData2 -> trace "Sandbox handleMessage called" Nothing
|
||||
| otherwise -> Nothing
|
||||
Nothing -> Nothing
|
||||
|
||||
render renderer wenv WidgetInstance{..} =
|
||||
do
|
||||
drawStyledBackground renderer _instanceRenderArea _instanceStyle
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle (T.pack label)
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText (T.pack label)
|
||||
sizeReq = SizeReq size FlexibleSize FlexibleSize
|
||||
|
||||
render renderer wenv WidgetInstance{..} = do
|
||||
drawStyledBackground renderer _instanceRenderArea _instanceStyle
|
||||
drawStyledText_ renderer _instanceRenderArea _instanceStyle (T.pack label)
|
||||
|
||||
@ -25,7 +25,10 @@ import Monomer.Widget.BaseContainer
|
||||
import Monomer.Widget.Types
|
||||
import Monomer.Widget.Util
|
||||
|
||||
data ActiveBar = HBar | VBar deriving (Eq)
|
||||
data ActiveBar
|
||||
= HBar
|
||||
| VBar
|
||||
deriving (Eq)
|
||||
|
||||
data ScrollConfig = ScrollConfig {
|
||||
_scActiveBarColor :: Maybe Color,
|
||||
@ -44,7 +47,9 @@ data ScrollState = ScrollState {
|
||||
_sstReqSize :: Tree SizeReq
|
||||
} deriving (Typeable)
|
||||
|
||||
newtype ScrollMessage = ScrollTo Rect deriving Typeable
|
||||
newtype ScrollMessage
|
||||
= ScrollTo Rect
|
||||
deriving Typeable
|
||||
|
||||
data ScrollContext = ScrollContext {
|
||||
hScrollRatio :: Double,
|
||||
@ -61,6 +66,7 @@ data ScrollContext = ScrollContext {
|
||||
vThumbRect :: Rect
|
||||
}
|
||||
|
||||
scrollConfig :: ScrollConfig
|
||||
scrollConfig = ScrollConfig {
|
||||
_scActiveBarColor = Just $ darkGray { _alpha = 0.4 },
|
||||
_scIdleBarColor = Nothing,
|
||||
@ -70,6 +76,7 @@ scrollConfig = ScrollConfig {
|
||||
_scWheelRate = 10
|
||||
}
|
||||
|
||||
defaultState :: ScrollState
|
||||
defaultState = ScrollState {
|
||||
_sstDragging = Nothing,
|
||||
_sstDeltaX = 0,
|
||||
@ -82,7 +89,7 @@ scroll :: WidgetInstance s e -> WidgetInstance s e
|
||||
scroll managedWidget = scroll_ scrollConfig managedWidget
|
||||
|
||||
scroll_ :: ScrollConfig -> WidgetInstance s e -> WidgetInstance s e
|
||||
scroll_ config managedWidget = makeInstance (makeScroll config defaultState) managedWidget
|
||||
scroll_ config managed = makeInstance (makeScroll config defaultState) managed
|
||||
|
||||
makeInstance :: Widget s e -> WidgetInstance s e -> WidgetInstance s e
|
||||
makeInstance widget managedWidget = (defaultWidgetInstance "scroll" widget) {
|
||||
@ -91,7 +98,8 @@ makeInstance widget managedWidget = (defaultWidgetInstance "scroll" widget) {
|
||||
}
|
||||
|
||||
makeScroll :: ScrollConfig -> ScrollState -> Widget s e
|
||||
makeScroll config state@(ScrollState dragging dx dy cs prevReqs) = createContainer {
|
||||
makeScroll config state = widget where
|
||||
widget = createContainer {
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = containerMergeTrees merge,
|
||||
_widgetHandleEvent = containerHandleEvent handleEvent,
|
||||
@ -100,162 +108,205 @@ makeScroll config state@(ScrollState dragging dx dy cs prevReqs) = createContain
|
||||
_widgetResize = scrollResize Nothing,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
Size childWidth childHeight = cs
|
||||
|
||||
merge wenv oldState widgetInst = resultWidget newInstance where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
ScrollState dragging dx dy cs prevReqs = state
|
||||
Size childWidth childHeight = cs
|
||||
|
||||
merge wenv oldState widgetInst = resultWidget newInstance where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeScroll config newState
|
||||
}
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
ButtonAction point btn status -> result where
|
||||
leftPressed = status == PressedBtn && btn == LeftBtn
|
||||
btnReleased = status == ReleasedBtn
|
||||
isDragging = isJust $ _sstDragging state
|
||||
startDrag = leftPressed && not isDragging
|
||||
jumpScroll = btnReleased && not isDragging
|
||||
newState
|
||||
| startDrag && hMouseInThumb = state { _sstDragging = Just HBar }
|
||||
| startDrag && vMouseInThumb = state { _sstDragging = Just VBar }
|
||||
| jumpScroll && hMouseInScroll =
|
||||
updateScrollThumb state HBar point viewport sctx
|
||||
| jumpScroll && vMouseInScroll =
|
||||
updateScrollThumb state VBar point viewport sctx
|
||||
| btnReleased = state { _sstDragging = Nothing }
|
||||
| otherwise = state
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeScroll config newState
|
||||
}
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
ButtonAction point btn status -> result where
|
||||
isLeftPressed = status == PressedBtn && btn == LeftBtn
|
||||
isButtonReleased = status == ReleasedBtn
|
||||
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 { _sstDragging = Nothing }
|
||||
| otherwise -> state
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeScroll config newState
|
||||
}
|
||||
handledResult = Just $ resultReqs [IgnoreChildrenEvents] newInstance
|
||||
result = if | isLeftPressed && (hMouseInThumb || vMouseInThumb) -> handledResult
|
||||
| isButtonReleased && (hMouseInScroll || vMouseInScroll) -> handledResult
|
||||
| isButtonReleased && isDragging -> handledResult
|
||||
| otherwise -> Nothing
|
||||
Click point btn -> result where
|
||||
isDragging = isJust $ _sstDragging state
|
||||
handledResult = Just $ resultReqs [IgnoreChildrenEvents] widgetInst
|
||||
result = if | hMouseInScroll || vMouseInScroll || isDragging -> handledResult
|
||||
| otherwise -> Nothing
|
||||
Move point -> result where
|
||||
updatedState = fmap (\dg -> updateScrollThumb state dg point viewport sctx) dragging
|
||||
makeResult newState = resultReqs [IgnoreChildrenEvents] (rebuildWidget wenv newState widgetInst prevReqs)
|
||||
result = fmap makeResult updatedState
|
||||
WheelScroll _ (Point wx wy) wheelDirection -> result where
|
||||
needsUpdate = (wx /= 0 && childWidth > vw) || (wy /= 0 && childHeight > vh)
|
||||
result = if | needsUpdate -> Just $ resultReqs [IgnoreChildrenEvents] (rebuildWidget wenv newState widgetInst 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 {
|
||||
_sstDeltaX = scrollAxis stepX dx childWidth vw,
|
||||
_sstDeltaY = scrollAxis stepY dy childHeight vh
|
||||
}
|
||||
_ -> Nothing
|
||||
where
|
||||
viewport = _instanceViewport widgetInst
|
||||
Rect vx vy vw vh = _instanceViewport widgetInst
|
||||
sctx@ScrollContext{..} = scrollStatus config wenv state viewport
|
||||
|
||||
scrollAxis reqDelta currScroll childPos viewportLimit
|
||||
| reqDelta >= 0 = if currScroll + reqDelta < 0
|
||||
then currScroll + reqDelta
|
||||
else 0
|
||||
| otherwise = if childPos - viewportLimit + currScroll + reqDelta > 0
|
||||
then currScroll + reqDelta
|
||||
else viewportLimit - childPos
|
||||
|
||||
handleMessage wenv ctx message widgetInst = cast message >>= handleScrollMessage where
|
||||
handleScrollMessage (ScrollTo rect) = scrollTo wenv widgetInst rect
|
||||
|
||||
scrollTo wenv widgetInst rect
|
||||
| rectInRect rect viewport = Nothing
|
||||
| otherwise = Just $ resultWidget newInstance
|
||||
where
|
||||
viewport = _instanceViewport widgetInst
|
||||
Rect rx ry rw rh = rect
|
||||
Rect vx vy vw vh = viewport
|
||||
diffL = vx - rx
|
||||
diffR = vx + vw - (rx + rw)
|
||||
diffT = vy - ry
|
||||
diffB = vy + vh - (ry + rh)
|
||||
stepX = if | rectInRectH rect viewport -> dx
|
||||
| abs diffL <= abs diffR -> diffL + dx
|
||||
| otherwise -> diffR + dx
|
||||
stepY = if | rectInRectV rect viewport -> dy
|
||||
| abs diffT <= abs diffB -> diffT + dy
|
||||
| otherwise -> diffB + dy
|
||||
newState = state {
|
||||
_sstDeltaX = scrollAxis stepX 0 childWidth vw,
|
||||
_sstDeltaY = scrollAxis stepY 0 childHeight vh
|
||||
}
|
||||
newInstance = rebuildWidget wenv newState widgetInst prevReqs
|
||||
|
||||
updateScrollThumb state activeBar point viewport sctx = newState where
|
||||
Point px py = point
|
||||
ScrollContext{..} = sctx
|
||||
Rect rx ry rw rh = viewport
|
||||
hMid = _rw hThumbRect / 2
|
||||
vMid = _rh vThumbRect / 2
|
||||
hDelta = (rx - px + hMid) / hScrollRatio
|
||||
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 { _sstDeltaX = newDeltaX, _sstDeltaY = newDeltaY }
|
||||
|
||||
rebuildWidget wenv newState widgetInst reqs = newInstance where
|
||||
newWidget = makeScroll config newState
|
||||
tempInstance = widgetInst { _instanceWidget = newWidget }
|
||||
newInstance = scrollResize (Just newWidget) wenv (_instanceViewport tempInstance) (_instanceRenderArea tempInstance) tempInstance reqs
|
||||
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
sizeReq = SizeReq (_sizeRequested . nodeValue $ Seq.index reqs 0) FlexibleSize FlexibleSize
|
||||
|
||||
scrollResize updatedWidget wenv viewport renderArea widgetInst reqs = newInstance where
|
||||
Rect l t w h = renderArea
|
||||
child = Seq.index (_instanceChildren widgetInst) 0
|
||||
childReq = fromMaybe (singleNode def) (Seq.lookup 0 (nodeChildren reqs))
|
||||
|
||||
Size childWidth2 childHeight2 = _sizeRequested $ nodeValue childReq
|
||||
areaW = max w childWidth2
|
||||
areaH = max h childHeight2
|
||||
childRenderArea = Rect (l + dx) (t + dy) areaW areaH
|
||||
|
||||
newWidget = fromMaybe (makeScroll config $ state { _sstChildSize = Size areaW areaH, _sstReqSize = reqs }) updatedWidget
|
||||
newChildWidget = _widgetResize (_instanceWidget child) wenv viewport childRenderArea child childReq
|
||||
|
||||
newInstance = widgetInst {
|
||||
_instanceViewport = viewport,
|
||||
_instanceRenderArea = renderArea,
|
||||
_instanceWidget = newWidget,
|
||||
_instanceChildren = Seq.singleton newChildWidget
|
||||
handledResult = Just $ resultReqs [IgnoreChildrenEvents] newInstance
|
||||
result
|
||||
| leftPressed && (hMouseInThumb || vMouseInThumb) = handledResult
|
||||
| btnReleased && (hMouseInScroll || vMouseInScroll) = handledResult
|
||||
| btnReleased && isDragging = handledResult
|
||||
| otherwise = Nothing
|
||||
Click point btn -> result where
|
||||
isDragging = isJust $ _sstDragging state
|
||||
handledResult = Just $ resultReqs [IgnoreChildrenEvents] widgetInst
|
||||
result
|
||||
| hMouseInScroll || vMouseInScroll || isDragging = handledResult
|
||||
| otherwise = Nothing
|
||||
Move point -> result where
|
||||
drag bar = updateScrollThumb state bar point viewport sctx
|
||||
makeWidget state = rebuildWidget wenv state widgetInst prevReqs
|
||||
makeResult state = resultReqs [IgnoreChildrenEvents] (makeWidget state)
|
||||
result = fmap (makeResult . drag) dragging
|
||||
WheelScroll _ (Point wx wy) wheelDirection -> result where
|
||||
changedX = wx /= 0 && childWidth > vw
|
||||
changedY = wy /= 0 && childHeight > vh
|
||||
needsUpdate = changedX || changedY
|
||||
makeWidget state = rebuildWidget wenv state widgetInst prevReqs
|
||||
makeResult state = resultReqs [IgnoreChildrenEvents] (makeWidget state)
|
||||
wheelRate = _scWheelRate config
|
||||
result
|
||||
| needsUpdate = Just $ makeResult newState
|
||||
| otherwise = Nothing
|
||||
stepX
|
||||
| wheelDirection == WheelNormal = -wheelRate * wx
|
||||
| otherwise = wheelRate * wx
|
||||
stepY
|
||||
| wheelDirection == WheelNormal = wheelRate * wy
|
||||
| otherwise = -wheelRate * wy
|
||||
newState = state {
|
||||
_sstDeltaX = scrollAxis stepX dx childWidth vw,
|
||||
_sstDeltaY = scrollAxis stepY dy childHeight vh
|
||||
}
|
||||
_ -> Nothing
|
||||
where
|
||||
viewport = _instanceViewport widgetInst
|
||||
Rect vx vy vw vh = _instanceViewport widgetInst
|
||||
sctx@ScrollContext{..} = scrollStatus config wenv state viewport
|
||||
|
||||
render renderer wenv widgetInst =
|
||||
do
|
||||
setScissor renderer viewport
|
||||
containerRender defaultContainerRender renderer wenv widgetInst
|
||||
resetScissor renderer
|
||||
scrollAxis reqDelta currScroll childPos vpLimit
|
||||
| reqDelta >= 0 && currScroll + reqDelta < 0 = currScroll + reqDelta
|
||||
| reqDelta >= 0 = 0
|
||||
| childPos - vpLimit + currScroll + reqDelta > 0 = currScroll + reqDelta
|
||||
| otherwise = vpLimit - childPos
|
||||
|
||||
when hScrollRequired $
|
||||
drawRect renderer hScrollRect barColorH Nothing
|
||||
handleMessage wenv ctx message widgetInst = result where
|
||||
handleScrollMessage (ScrollTo rect) = scrollTo wenv widgetInst rect
|
||||
result = cast message >>= handleScrollMessage
|
||||
|
||||
when vScrollRequired $
|
||||
drawRect renderer vScrollRect barColorV Nothing
|
||||
scrollTo wenv widgetInst rect
|
||||
| rectInRect rect viewport = Nothing
|
||||
| otherwise = Just $ resultWidget newInstance
|
||||
where
|
||||
viewport = _instanceViewport widgetInst
|
||||
Rect rx ry rw rh = rect
|
||||
Rect vx vy vw vh = viewport
|
||||
diffL = vx - rx
|
||||
diffR = vx + vw - (rx + rw)
|
||||
diffT = vy - ry
|
||||
diffB = vy + vh - (ry + rh)
|
||||
stepX
|
||||
| rectInRectH rect viewport = dx
|
||||
| abs diffL <= abs diffR = diffL + dx
|
||||
| otherwise = diffR + dx
|
||||
stepY
|
||||
| rectInRectV rect viewport = dy
|
||||
| abs diffT <= abs diffB = diffT + dy
|
||||
| otherwise = diffB + dy
|
||||
newState = state {
|
||||
_sstDeltaX = scrollAxis stepX 0 childWidth vw,
|
||||
_sstDeltaY = scrollAxis stepY 0 childHeight vh
|
||||
}
|
||||
newInstance = rebuildWidget wenv newState widgetInst prevReqs
|
||||
|
||||
when hScrollRequired $
|
||||
drawRect renderer hThumbRect (Just thumbColorH) Nothing
|
||||
updateScrollThumb state activeBar point viewport sctx = newState where
|
||||
Point px py = point
|
||||
ScrollContext{..} = sctx
|
||||
Rect rx ry rw rh = viewport
|
||||
hMid = _rw hThumbRect / 2
|
||||
vMid = _rh vThumbRect / 2
|
||||
hDelta = (rx - px + hMid) / hScrollRatio
|
||||
vDelta = (ry - py + vMid) / vScrollRatio
|
||||
newDeltaX
|
||||
| activeBar == HBar = scrollAxis hDelta 0 childWidth rw
|
||||
| otherwise = dx
|
||||
newDeltaY
|
||||
| activeBar == VBar = scrollAxis vDelta 0 childHeight rh
|
||||
| otherwise = dy
|
||||
newState = state {
|
||||
_sstDeltaX = newDeltaX,
|
||||
_sstDeltaY = newDeltaY
|
||||
}
|
||||
|
||||
when vScrollRequired $
|
||||
drawRect renderer vThumbRect (Just thumbColorV) Nothing
|
||||
where
|
||||
viewport = _instanceViewport widgetInst
|
||||
ScrollContext{..} = scrollStatus config wenv 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
|
||||
rebuildWidget wenv newState widgetInst reqs = newInst where
|
||||
newWidget = makeScroll config newState
|
||||
tempInst = widgetInst { _instanceWidget = newWidget }
|
||||
widget = _instanceViewport tempInst
|
||||
renderArea = _instanceRenderArea tempInst
|
||||
newInst = scrollResize (Just newWidget) wenv widget renderArea tempInst reqs
|
||||
|
||||
scrollStatus :: ScrollConfig -> WidgetEnv s e -> ScrollState -> Rect -> ScrollContext
|
||||
preferredSize wenv widgetInst children reqs = Node sizeReq reqs where
|
||||
size = _sizeRequested . nodeValue $ Seq.index reqs 0
|
||||
sizeReq = SizeReq size FlexibleSize FlexibleSize
|
||||
|
||||
scrollResize uWidget wenv viewport renderArea widgetInst reqs = newInst where
|
||||
Rect l t w h = renderArea
|
||||
child = Seq.index (_instanceChildren widgetInst) 0
|
||||
childReq = fromMaybe (singleNode def) (Seq.lookup 0 (nodeChildren reqs))
|
||||
|
||||
Size childWidth2 childHeight2 = _sizeRequested $ nodeValue childReq
|
||||
areaW = max w childWidth2
|
||||
areaH = max h childHeight2
|
||||
cRenderArea = Rect (l + dx) (t + dy) areaW areaH
|
||||
|
||||
defWidget = makeScroll config $ state {
|
||||
_sstChildSize = Size areaW areaH,
|
||||
_sstReqSize = reqs
|
||||
}
|
||||
newWidget = fromMaybe defWidget uWidget
|
||||
cWidget = _instanceWidget child
|
||||
newChild = _widgetResize cWidget wenv viewport cRenderArea child childReq
|
||||
|
||||
newInst = widgetInst {
|
||||
_instanceViewport = viewport,
|
||||
_instanceRenderArea = renderArea,
|
||||
_instanceWidget = newWidget,
|
||||
_instanceChildren = Seq.singleton newChild
|
||||
}
|
||||
|
||||
render renderer wenv widgetInst = do
|
||||
setScissor renderer viewport
|
||||
containerRender defaultContainerRender renderer wenv widgetInst
|
||||
resetScissor renderer
|
||||
|
||||
when hScrollRequired $
|
||||
drawRect renderer hScrollRect barColorH Nothing
|
||||
|
||||
when vScrollRequired $
|
||||
drawRect renderer vScrollRect barColorV Nothing
|
||||
|
||||
when hScrollRequired $
|
||||
drawRect renderer hThumbRect (Just thumbColorH) Nothing
|
||||
|
||||
when vScrollRequired $
|
||||
drawRect renderer vThumbRect (Just thumbColorV) Nothing
|
||||
|
||||
where
|
||||
viewport = _instanceViewport widgetInst
|
||||
ScrollContext{..} = scrollStatus config wenv state viewport
|
||||
draggingH = _sstDragging state == Just HBar
|
||||
draggingV = _sstDragging state == Just VBar
|
||||
barColorH
|
||||
| hMouseInScroll = _scActiveBarColor config
|
||||
| otherwise = _scIdleBarColor config
|
||||
barColorV
|
||||
| vMouseInScroll = _scActiveBarColor config
|
||||
| otherwise = _scIdleBarColor config
|
||||
thumbColorH
|
||||
| hMouseInThumb || draggingH = _scActiveThumbColor config
|
||||
| otherwise = _scIdleThumbColor config
|
||||
thumbColorV
|
||||
| vMouseInThumb || draggingV = _scActiveThumbColor config
|
||||
| otherwise = _scIdleThumbColor config
|
||||
|
||||
scrollStatus
|
||||
:: ScrollConfig -> WidgetEnv s e -> ScrollState -> Rect -> ScrollContext
|
||||
scrollStatus config wenv scrollState viewport = ScrollContext{..} where
|
||||
ScrollState _ dx dy (Size childWidth childHeight) _ = scrollState
|
||||
barThickness = _scBarThickness config
|
||||
@ -270,10 +321,20 @@ scrollStatus config wenv scrollState viewport = ScrollContext{..} where
|
||||
vScrollRatio = min (vpHeight / childHeight) 1
|
||||
hScrollRequired = hScrollRatio < 1
|
||||
vScrollRequired = vScrollRatio < 1
|
||||
hScrollRect = Rect vpLeft (vpTop + hScrollTop) (vpLeft + vpWidth) (vpTop + vpHeight)
|
||||
vScrollRect = Rect (vpLeft + vScrollLeft) vpTop (vpLeft + vpWidth) (vpTop + vpHeight)
|
||||
hThumbRect = Rect (vpLeft - hScrollRatio * dx) (vpTop + hScrollTop) (hScrollRatio * vpWidth) barThickness
|
||||
vThumbRect = Rect (vpLeft + vScrollLeft) (vpTop - vScrollRatio * dy) barThickness (vScrollRatio * vpHeight)
|
||||
hScrollRect =
|
||||
Rect vpLeft (vpTop + hScrollTop) (vpLeft + vpWidth) (vpTop + vpHeight)
|
||||
vScrollRect =
|
||||
Rect (vpLeft + vScrollLeft) vpTop (vpLeft + vpWidth) (vpTop + vpHeight)
|
||||
hThumbRect = Rect
|
||||
(vpLeft - hScrollRatio * dx)
|
||||
(vpTop + hScrollTop)
|
||||
(hScrollRatio * vpWidth)
|
||||
barThickness
|
||||
vThumbRect = Rect
|
||||
(vpLeft + vScrollLeft)
|
||||
(vpTop - vScrollRatio * dy)
|
||||
barThickness
|
||||
(vScrollRatio * vpHeight)
|
||||
hMouseInScroll = pointInRect mousePos hScrollRect
|
||||
vMouseInScroll = pointInRect mousePos vScrollRect
|
||||
hMouseInThumb = pointInRect mousePos hThumbRect
|
||||
|
||||
@ -16,9 +16,11 @@ defaultSpace :: Double
|
||||
defaultSpace = 10
|
||||
|
||||
makeSpacer :: Widget s e
|
||||
makeSpacer = createWidget {
|
||||
makeSpacer = widget where
|
||||
widget = createWidget {
|
||||
_widgetPreferredSize = preferredSize
|
||||
}
|
||||
where
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
sizeReq = SizeReq (Size defaultSpace defaultSpace) RemainderSize RemainderSize
|
||||
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
size = Size defaultSpace defaultSpace
|
||||
sizeReq = SizeReq size RemainderSize RemainderSize
|
||||
|
||||
@ -28,73 +28,85 @@ vstack children = (defaultWidgetInstance "vstack" (makeStack False)) {
|
||||
}
|
||||
|
||||
makeStack :: Bool -> Widget s e
|
||||
makeStack isHorizontal = createContainer {
|
||||
makeStack isHorizontal = widget where
|
||||
widget = createContainer {
|
||||
_widgetPreferredSize = containerPreferredSize preferredSize,
|
||||
_widgetResize = containerResize resize
|
||||
}
|
||||
where
|
||||
preferredSize wenv widgetInst children reqs = Node reqSize reqs where
|
||||
(_, vreqs) = visibleChildrenReq children reqs
|
||||
reqSize = SizeReq (calcPreferredSize vreqs) FlexibleSize FlexibleSize
|
||||
|
||||
resize wenv viewport renderArea widgetInst children reqs = (widgetInst, assignedArea) where
|
||||
Rect l t w h = renderArea
|
||||
childrenPairs = Seq.zip children reqs
|
||||
(vchildren, vreqs) = visibleChildrenReq children reqs
|
||||
mainSize = if isHorizontal then w else h
|
||||
mainStart = if isHorizontal then l else t
|
||||
policyFilter policy req = policySelector req == policy
|
||||
sChildren = Seq.filter (policyFilter StrictSize) vreqs
|
||||
fChildren = Seq.filter (policyFilter FlexibleSize) vreqs
|
||||
rChildren = Seq.filter (policyFilter RemainderSize) vreqs
|
||||
fExists = not $ null fChildren
|
||||
rExists = not $ null rChildren
|
||||
sSize = sizeSelector $ calcPreferredSize sChildren
|
||||
fSize = sizeSelector $ calcPreferredSize fChildren
|
||||
rSize = max 0 (mainSize - sSize)
|
||||
fCount = fromIntegral $ length fChildren
|
||||
rCount = fromIntegral $ length rChildren
|
||||
fAvg = if fExists then fSize / fCount else 0
|
||||
fBigFilter c = sizeSelector (_sizeRequested c) >= fAvg
|
||||
fBigSize = sizeSelector $ calcPreferredSize (Seq.filter fBigFilter fChildren)
|
||||
fExtra = if fExists then (rSize - fSize) / fBigSize else 0
|
||||
rUnit = if rExists && not fExists then rSize / rCount else 0
|
||||
assignedArea = Seq.zip newViewports newViewports
|
||||
(newViewports, _) = foldl' foldHelper (Seq.empty, mainStart) childrenPairs
|
||||
foldHelper (accum, offset) childPair = (newAccum, newOffset) where
|
||||
newSize = resizeChild renderArea fAvg fExtra rUnit offset childPair
|
||||
newAccum = accum |> newSize
|
||||
newOffset = offset + rectSelector newSize
|
||||
preferredSize wenv widgetInst children reqs = Node reqSize reqs where
|
||||
(_, vreqs) = visibleChildrenReq children reqs
|
||||
reqSize = SizeReq (calcPreferredSize vreqs) FlexibleSize FlexibleSize
|
||||
|
||||
resizeChild renderArea fAvg fExtra rUnit offset childPair = result where
|
||||
Rect l t w h = renderArea
|
||||
result = if | not $ _instanceVisible childInstance -> emptyRect
|
||||
| isHorizontal -> hRect
|
||||
| otherwise -> vRect
|
||||
childInstance = fst childPair
|
||||
req = nodeValue $ snd childPair
|
||||
srSize = _sizeRequested req
|
||||
emptyRect = Rect l t 0 0
|
||||
hRect = Rect offset t calcNewSize h
|
||||
vRect = Rect l offset w calcNewSize
|
||||
calcNewSize = case policySelector req of
|
||||
StrictSize -> sizeSelector srSize
|
||||
FlexibleSize
|
||||
| sizeSelector srSize >= fAvg -> (1 + fExtra) * sizeSelector srSize
|
||||
| otherwise -> sizeSelector srSize
|
||||
RemainderSize -> rUnit
|
||||
resize wenv viewport renderArea widgetInst children reqs = resized where
|
||||
Rect l t w h = renderArea
|
||||
childrenPairs = Seq.zip children reqs
|
||||
(vchildren, vreqs) = visibleChildrenReq children reqs
|
||||
mainSize = if isHorizontal then w else h
|
||||
mainStart = if isHorizontal then l else t
|
||||
policyFilter policy req = policySelector req == policy
|
||||
sChildren = Seq.filter (policyFilter StrictSize) vreqs
|
||||
fChildren = Seq.filter (policyFilter FlexibleSize) vreqs
|
||||
rChildren = Seq.filter (policyFilter RemainderSize) vreqs
|
||||
fExists = not $ null fChildren
|
||||
rExists = not $ null rChildren
|
||||
sSize = sizeSelector $ calcPreferredSize sChildren
|
||||
fSize = sizeSelector $ calcPreferredSize fChildren
|
||||
rSize = max 0 (mainSize - sSize)
|
||||
fCount = fromIntegral $ length fChildren
|
||||
rCount = fromIntegral $ length rChildren
|
||||
fAvg = if fExists then fSize / fCount else 0
|
||||
fLargeFilter c = sizeSelector (_sizeRequested c) >= fAvg
|
||||
fLargeFiltered = Seq.filter fLargeFilter fChildren
|
||||
fLargeSize = sizeSelector $ calcPreferredSize fLargeFiltered
|
||||
fExtra
|
||||
| fExists = (rSize - fSize) / fLargeSize
|
||||
| otherwise = 0
|
||||
rUnit
|
||||
| rExists && not fExists = rSize / rCount
|
||||
| otherwise = 0
|
||||
assignedArea = Seq.zip newViewports newViewports
|
||||
(newViewports, _) = foldl' foldHelper (Seq.empty, mainStart) childrenPairs
|
||||
foldHelper (accum, offset) childPair = (newAccum, newOffset) where
|
||||
newSize = resizeChild renderArea fAvg fExtra rUnit offset childPair
|
||||
newAccum = accum |> newSize
|
||||
newOffset = offset + rectSelector newSize
|
||||
resized = (widgetInst, assignedArea)
|
||||
|
||||
calcPreferredSize vreqs = Size width height where
|
||||
(maxWidth, sumWidth, maxHeight, sumHeight) = calcDimensions vreqs
|
||||
width = if isHorizontal then sumWidth else maxWidth
|
||||
height = if isHorizontal then maxHeight else sumHeight
|
||||
resizeChild renderArea fAvg fExtra rUnit offset childPair = result where
|
||||
Rect l t w h = renderArea
|
||||
childInstance = fst childPair
|
||||
req = nodeValue $ snd childPair
|
||||
srSize = _sizeRequested req
|
||||
emptyRect = Rect l t 0 0
|
||||
hRect = Rect offset t calcNewSize h
|
||||
vRect = Rect l offset w calcNewSize
|
||||
calcNewSize = case policySelector req of
|
||||
StrictSize -> sizeSelector srSize
|
||||
FlexibleSize
|
||||
| sizeSelector srSize >= fAvg -> (1 + fExtra) * sizeSelector srSize
|
||||
| otherwise -> sizeSelector srSize
|
||||
RemainderSize -> rUnit
|
||||
result
|
||||
| not $ _instanceVisible childInstance = emptyRect
|
||||
| isHorizontal = hRect
|
||||
| otherwise = vRect
|
||||
|
||||
calcDimensions vreqs = (maxWidth, sumWidth, maxHeight, sumHeight) where
|
||||
maxWidth = if Seq.null vreqs then 0 else (maximum . fmap (_w . _sizeRequested)) vreqs
|
||||
sumWidth = (sum . fmap (_w . _sizeRequested)) vreqs
|
||||
maxHeight = if null vreqs then 0 else (maximum . fmap (_h . _sizeRequested)) vreqs
|
||||
sumHeight = (sum . fmap (_h . _sizeRequested)) vreqs
|
||||
calcPreferredSize vreqs = Size width height where
|
||||
(maxWidth, sumWidth, maxHeight, sumHeight) = calcDimensions vreqs
|
||||
width = if isHorizontal then sumWidth else maxWidth
|
||||
height = if isHorizontal then maxHeight else sumHeight
|
||||
|
||||
sizeSelector = if isHorizontal then _w else _h
|
||||
rectSelector = if isHorizontal then _rw else _rh
|
||||
policySelector = if isHorizontal then _sizePolicyWidth else _sizePolicyHeight
|
||||
calcDimensions vreqs = (maxWidth, sumWidth, maxHeight, sumHeight) where
|
||||
sumWidth = (sum . fmap (_w . _sizeRequested)) vreqs
|
||||
sumHeight = (sum . fmap (_h . _sizeRequested)) vreqs
|
||||
maxWidth
|
||||
| Seq.null vreqs = 0
|
||||
| otherwise = (maximum . fmap (_w . _sizeRequested)) vreqs
|
||||
maxHeight
|
||||
| Seq.null vreqs = 0
|
||||
| otherwise = (maximum . fmap (_h . _sizeRequested)) vreqs
|
||||
|
||||
sizeSelector = if isHorizontal then _w else _h
|
||||
rectSelector = if isHorizontal then _rw else _rh
|
||||
policySelector = if isHorizontal then _sizePolicyWidth else _sizePolicyHeight
|
||||
|
||||
@ -68,7 +68,8 @@ makeInstance widget = (defaultWidgetInstance "textField" widget) {
|
||||
}
|
||||
|
||||
makeTextField :: TextFieldConfig s e -> TextFieldState -> Widget s e
|
||||
makeTextField config state = createWidget {
|
||||
makeTextField config state = widget where
|
||||
widget = createWidget {
|
||||
_widgetInit = init,
|
||||
_widgetGetState = makeState state,
|
||||
_widgetMerge = widgetMerge merge,
|
||||
@ -76,83 +77,89 @@ makeTextField config state = createWidget {
|
||||
_widgetPreferredSize = preferredSize,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
TextFieldState currText currPos = state
|
||||
(part1, part2) = T.splitAt currPos currText
|
||||
currentValue wenv = widgetValueGet (_weModel wenv) (_tfcValue config)
|
||||
|
||||
init wenv widgetInst = resultWidget newInstance where
|
||||
currText = currentValue wenv
|
||||
newState = TextFieldState currText 0
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeTextField config newState
|
||||
}
|
||||
TextFieldState currText currPos = state
|
||||
(part1, part2) = T.splitAt currPos currText
|
||||
currentValue wenv = widgetValueGet (_weModel wenv) (_tfcValue config)
|
||||
|
||||
merge wenv oldState widgetInst = resultWidget newInstance where
|
||||
TextFieldState _ oldPos = fromMaybe textFieldState (useState oldState)
|
||||
currText = currentValue wenv
|
||||
newPos = if | T.length currText < oldPos -> T.length currText
|
||||
| otherwise -> oldPos
|
||||
newState = TextFieldState currText newPos
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeTextField config newState
|
||||
}
|
||||
init wenv widgetInst = resultWidget newInstance where
|
||||
currText = currentValue wenv
|
||||
newState = TextFieldState currText 0
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeTextField config newState
|
||||
}
|
||||
|
||||
handleKeyPress txt tp code
|
||||
| isKeyBackspace code && tp > 0 = (T.append (T.init part1) part2, tp - 1)
|
||||
| isKeyLeft code && tp > 0 = (txt, tp - 1)
|
||||
| isKeyRight code && tp < T.length txt = (txt, tp + 1)
|
||||
| isKeyBackspace code || isKeyLeft code || isKeyRight code = (txt, tp)
|
||||
| otherwise = (txt, tp)
|
||||
merge wenv oldState widgetInst = resultWidget newInstance where
|
||||
TextFieldState _ oldPos = fromMaybe textFieldState (useState oldState)
|
||||
currText = currentValue wenv
|
||||
newPos = if | T.length currText < oldPos -> T.length currText
|
||||
| otherwise -> oldPos
|
||||
newState = TextFieldState currText newPos
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeTextField config newState
|
||||
}
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
Click (Point x y) _ -> Just $ resultReqs reqs widgetInst where
|
||||
reqs = [SetFocus $ _instancePath widgetInst]
|
||||
handleKeyPress txt tp code
|
||||
| isKeyBackspace code && tp > 0 = (T.append (T.init part1) part2, tp - 1)
|
||||
| isKeyLeft code && tp > 0 = (txt, tp - 1)
|
||||
| isKeyRight code && tp < T.length txt = (txt, tp + 1)
|
||||
| isKeyBackspace code || isKeyLeft code || isKeyRight code = (txt, tp)
|
||||
| otherwise = (txt, tp)
|
||||
|
||||
KeyAction mod code KeyPressed -> Just $ resultReqs reqs newInstance where
|
||||
(newText, newPos) = handleKeyPress currText currPos code
|
||||
reqGetClipboard = [GetClipboard (_instancePath widgetInst) | isClipboardPaste wenv evt]
|
||||
reqSetClipboard = [SetClipboard (ClipboardText currText) | isClipboardCopy wenv evt]
|
||||
reqUpdateModel = if | currText /= newText -> widgetValueSet (_tfcValue config) newText
|
||||
| otherwise -> []
|
||||
reqs = reqGetClipboard ++ reqSetClipboard ++ reqUpdateModel
|
||||
newState = TextFieldState newText newPos
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeTextField config newState
|
||||
}
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
Click (Point x y) _ -> Just $ resultReqs reqs widgetInst where
|
||||
reqs = [SetFocus $ _instancePath widgetInst]
|
||||
|
||||
TextInput newText -> insertText wenv widgetInst newText
|
||||
|
||||
Clipboard (ClipboardText newText) -> insertText wenv widgetInst newText
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
insertText wenv widgetInst addedText = Just $ resultReqs reqs newInstance where
|
||||
newText = T.concat [part1, addedText, part2]
|
||||
newPos = currPos + T.length addedText
|
||||
KeyAction mod code KeyPressed -> Just $ resultReqs reqs newInstance where
|
||||
(newText, newPos) = handleKeyPress currText currPos code
|
||||
isPaste = isClipboardPaste wenv evt
|
||||
isCopy = isClipboardCopy wenv evt
|
||||
reqGetClipboard = [GetClipboard (_instancePath widgetInst) | isPaste]
|
||||
reqSetClipboard = [SetClipboard (ClipboardText currText) | isCopy]
|
||||
reqUpdateModel
|
||||
| currText /= newText = widgetValueSet (_tfcValue config) newText
|
||||
| otherwise = []
|
||||
reqs = reqGetClipboard ++ reqSetClipboard ++ reqUpdateModel
|
||||
newState = TextFieldState newText newPos
|
||||
reqs = widgetValueSet (_tfcValue config) newText
|
||||
newInstance = widgetInst {
|
||||
_instanceWidget = makeTextField config newState
|
||||
}
|
||||
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText currText
|
||||
sizeReq = SizeReq size FlexibleSize StrictSize
|
||||
|
||||
render renderer wenv widgetInst =
|
||||
let WidgetInstance{..} = widgetInst
|
||||
ts = _weTimestamp wenv
|
||||
textStyle = _styleText _instanceStyle
|
||||
cursorAlpha = if isFocused wenv widgetInst then fromIntegral (ts `mod` 1000) / 1000.0 else 0
|
||||
textColor = (tsTextColor textStyle) { _alpha = cursorAlpha }
|
||||
renderArea@(Rect rl rt rw rh) = _instanceRenderArea
|
||||
in do
|
||||
drawStyledBackground renderer renderArea _instanceStyle
|
||||
Rect tl tt _ _ <- drawText renderer renderArea textStyle currText
|
||||
TextInput newText -> insertText wenv widgetInst newText
|
||||
|
||||
when (isFocused wenv widgetInst) $ do
|
||||
let Size sw sh = getTextBounds wenv textStyle part1
|
||||
drawRect renderer (Rect (tl + sw) tt (_tfcCaretWidth config) sh) (Just textColor) Nothing
|
||||
return ()
|
||||
Clipboard (ClipboardText newText) -> insertText wenv widgetInst newText
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
insertText wenv widgetInst addedText = Just $ resultReqs reqs newInst where
|
||||
newText = T.concat [part1, addedText, part2]
|
||||
newPos = currPos + T.length addedText
|
||||
newState = TextFieldState newText newPos
|
||||
reqs = widgetValueSet (_tfcValue config) newText
|
||||
newInst = widgetInst {
|
||||
_instanceWidget = makeTextField config newState
|
||||
}
|
||||
|
||||
preferredSize wenv widgetInst = singleNode sizeReq where
|
||||
Style{..} = _instanceStyle widgetInst
|
||||
size = getTextBounds wenv _styleText currText
|
||||
sizeReq = SizeReq size FlexibleSize StrictSize
|
||||
|
||||
render renderer wenv widgetInst = do
|
||||
drawStyledBackground renderer renderArea _instanceStyle
|
||||
Rect tl tt _ _ <- drawText renderer renderArea textStyle currText
|
||||
|
||||
when (isFocused wenv widgetInst) $ do
|
||||
let Size sw sh = getTextBounds wenv textStyle part1
|
||||
drawRect renderer (Rect (tl + sw) tt caretWidth sh) caretColor Nothing
|
||||
|
||||
where
|
||||
WidgetInstance{..} = widgetInst
|
||||
ts = _weTimestamp wenv
|
||||
renderArea@(Rect rl rt rw rh) = _instanceRenderArea
|
||||
textStyle = _styleText _instanceStyle
|
||||
caretAlpha
|
||||
| isFocused wenv widgetInst = fromIntegral (ts `mod` 1000) / 1000.0
|
||||
| otherwise = 0
|
||||
caretColor = Just $ (tsTextColor textStyle) { _alpha = caretAlpha }
|
||||
caretWidth = _tfcCaretWidth config
|
||||
|
||||
Loading…
Reference in New Issue
Block a user