mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-20 08:17:37 +03:00
Restrict area of focus changes. Improve dropdown communication with ListView
This commit is contained in:
Francisco Vallarino
parent
eb3344f705
commit
6dd083d7f2
@ -23,7 +23,6 @@ import Monomer.Core.Style
|
||||
import Monomer.Core.WidgetTypes
|
||||
import Monomer.Core.Util
|
||||
import Monomer.Graphics.Color
|
||||
import Monomer.Main.Util
|
||||
import Monomer.Widgets
|
||||
|
||||
data EditableItem = EditableItem {
|
||||
|
||||
@ -76,7 +76,12 @@ handleAppEvent model evt = case evt of
|
||||
_ -> Model model
|
||||
|
||||
buildUI :: App -> WidgetInstance App AppEvent
|
||||
buildUI model = trace "Creating UI" widgetTree where
|
||||
buildUI model = trace "Creating UI" widgetTree5 where
|
||||
widgetTree5 = vstack [
|
||||
textDropdown_ textField1 items id [onChange DropdownVal, onChangeIdx DropdownIdx] `style` [bgColor lightBlue],
|
||||
textField textField1 `style` [bgColor lightBlue, textLeft],
|
||||
image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200]
|
||||
]
|
||||
widgetTree = zstack [
|
||||
widgetTree3,
|
||||
alert "Message" CloseAlert `visible` model ^. showAlert,
|
||||
|
||||
@ -15,7 +15,6 @@ import TextShow
|
||||
import Monomer.Core.Combinators
|
||||
import Monomer.Core.Style
|
||||
import Monomer.Graphics.Color
|
||||
import Monomer.Main.Util
|
||||
import Monomer.Core.WidgetTypes
|
||||
import Monomer.Core.Util
|
||||
import Monomer.Widgets
|
||||
|
||||
@ -39,6 +39,9 @@ class OnTextOverflow t where
|
||||
textEllipsis :: t
|
||||
textClip :: t
|
||||
|
||||
class SelectOnBlur t where
|
||||
selectOnBlur :: Bool -> t
|
||||
|
||||
class SelectOnFocus t where
|
||||
selectOnFocus :: Bool -> t
|
||||
|
||||
@ -78,6 +81,12 @@ class Num a => MaxValue t a | t -> a where
|
||||
maxValue :: a -> t
|
||||
|
||||
-- Events
|
||||
class OnBlur t e | t -> e where
|
||||
onBlur :: e -> t
|
||||
|
||||
class OnBlurReq t s | t -> s where
|
||||
onBlurReq :: WidgetRequest s -> t
|
||||
|
||||
class OnClick t e | t -> e where
|
||||
onClick :: e -> t
|
||||
|
||||
|
||||
@ -130,7 +130,7 @@ runApp window theme fonts widgetRoot = do
|
||||
}
|
||||
|
||||
mainModel .= _weModel newWenv
|
||||
pathFocus .= findNextFocus newWenv FocusFwd rootPath resizedRoot
|
||||
pathFocus .= findNextFocus newWenv FocusFwd rootPath Nothing resizedRoot
|
||||
|
||||
mainLoop window renderer loopArgs
|
||||
|
||||
|
||||
@ -155,9 +155,10 @@ handleFocusChange
|
||||
handleFocusChange systemEvent stopProcessing (wenv, events, widgetRoot)
|
||||
| focusChangeRequested = do
|
||||
oldFocus <- use L.pathFocus
|
||||
overlay <- use L.pathOverlay
|
||||
(wenv1, events1, root1) <- handleSystemEvent wenv Blur oldFocus widgetRoot
|
||||
|
||||
let newFocus = findNextFocus wenv1 focusDirection oldFocus root1
|
||||
let newFocus = findNextFocus wenv1 focusDirection oldFocus overlay root1
|
||||
let tempWenv = wenv1 {
|
||||
_weFocusedPath = newFocus
|
||||
}
|
||||
|
||||
@ -34,11 +34,19 @@ initMonomerContext model winSize useHiDPI devicePixelRate = MonomerContext {
|
||||
}
|
||||
|
||||
findNextFocus
|
||||
:: WidgetEnv s e -> FocusDirection -> Path -> WidgetInstance s e -> Path
|
||||
findNextFocus wenv direction focus widgetRoot = fromJust nextFocus where
|
||||
:: WidgetEnv s e
|
||||
-> FocusDirection
|
||||
-> Path
|
||||
-> Maybe Path
|
||||
-> WidgetInstance s e
|
||||
-> Path
|
||||
findNextFocus wenv direction focus overlay widgetRoot = fromJust nextFocus where
|
||||
widget = _wiWidget widgetRoot
|
||||
candidateFocus = widgetFindNextFocus widget wenv direction focus widgetRoot
|
||||
fromRootFocus = widgetFindNextFocus widget wenv direction rootPath widgetRoot
|
||||
restartPath = fromMaybe rootPath overlay
|
||||
candidateFocus =
|
||||
widgetFindNextFocus widget wenv direction focus widgetRoot
|
||||
fromRootFocus =
|
||||
widgetFindNextFocus widget wenv direction restartPath widgetRoot
|
||||
nextFocus = candidateFocus <|> fromRootFocus <|> Just focus
|
||||
|
||||
resizeWidget
|
||||
|
||||
@ -5,8 +5,6 @@ module Monomer.Widgets.Alert (
|
||||
alert_
|
||||
) where
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Lens ((&), (.~))
|
||||
import Data.Default
|
||||
|
||||
@ -301,8 +301,8 @@ findNextFocusWrapper handler wenv direction start widgetInst = nextFocus where
|
||||
| direction == FocusFwd = handlerResult
|
||||
| otherwise = Seq.reverse handlerResult
|
||||
isBeforeTarget ch
|
||||
| direction == FocusFwd = isTargetBeforeCurrent start ch
|
||||
| otherwise = isTargetAfterCurrent start ch
|
||||
| direction == FocusFwd = isTargetBeforeWidget start ch
|
||||
| otherwise = isTargetAfterWidget start ch
|
||||
nextCandidate ch = widgetFindNextFocus (_wiWidget ch) wenv direction start ch
|
||||
filtered = Seq.filter isBeforeTarget children
|
||||
candidates = fmap nextCandidate filtered
|
||||
|
||||
@ -112,8 +112,9 @@ newtype DropdownState = DropdownState {
|
||||
_isOpen :: Bool
|
||||
}
|
||||
|
||||
newtype DropdownMessage
|
||||
data DropdownMessage
|
||||
= OnChangeMessage Int
|
||||
| OnListBlur
|
||||
deriving Typeable
|
||||
|
||||
dropdown
|
||||
@ -207,68 +208,70 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
isOpen = _isOpen state
|
||||
currentValue wenv = widgetDataGet (_weModel wenv) widgetData
|
||||
|
||||
createDropdown wenv newState widgetInst = newInstance where
|
||||
createDropdown wenv newState inst = newInstance where
|
||||
selected = currentValue wenv
|
||||
path = _wiPath widgetInst
|
||||
path = _wiPath inst
|
||||
listViewInst = makeListView widgetData items makeRow config path selected
|
||||
newWidget = makeDropdown widgetData items makeMain makeRow config newState
|
||||
newInstance = widgetInst {
|
||||
newInstance = inst {
|
||||
_wiWidget = newWidget,
|
||||
_wiChildren = Seq.singleton listViewInst
|
||||
}
|
||||
|
||||
init wenv widgetInst = resultWidget $ createDropdown wenv state widgetInst
|
||||
init wenv inst = resultWidget $ createDropdown wenv state inst
|
||||
|
||||
merge wenv oldState newInst = result where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
result = resultWidget $ createDropdown wenv newState newInst
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
handleEvent wenv target evt inst = case evt of
|
||||
Click point _
|
||||
| openRequired point widgetInst -> Just $ openDropdown wenv widgetInst
|
||||
| closeRequired point widgetInst -> Just $ closeDropdown wenv widgetInst
|
||||
| openRequired point inst -> Just $ openDropdown wenv inst
|
||||
| closeRequired point inst -> Just $ closeDropdown wenv inst
|
||||
KeyAction mode code status
|
||||
| isKeyOpenDropdown && not isOpen -> Just $ openDropdown wenv widgetInst
|
||||
| isKeyEsc code && isOpen -> Just $ closeDropdown wenv widgetInst
|
||||
| isKeyOpenDropdown && not isOpen -> Just $ openDropdown wenv inst
|
||||
| isKeyEsc code && isOpen -> Just $ closeDropdown wenv inst
|
||||
where isKeyOpenDropdown = isKeyDown code || isKeyUp code
|
||||
_
|
||||
| not isOpen -> Just $ resultReqs [IgnoreChildrenEvents] widgetInst
|
||||
| not isOpen -> Just $ resultReqs [IgnoreChildrenEvents] inst
|
||||
| otherwise -> Nothing
|
||||
|
||||
openRequired point widgetInst = not isOpen && inViewport where
|
||||
inViewport = pointInRect point (_wiViewport widgetInst)
|
||||
openRequired point inst = not isOpen && inViewport where
|
||||
inViewport = pointInRect point (_wiViewport inst)
|
||||
|
||||
closeRequired point widgetInst = isOpen && not inOverlay where
|
||||
inOverlay = case Seq.lookup 0 (_wiChildren widgetInst) of
|
||||
closeRequired point inst = isOpen && not inOverlay where
|
||||
inOverlay = case Seq.lookup 0 (_wiChildren inst) of
|
||||
Just inst -> pointInRect point (_wiViewport inst)
|
||||
Nothing -> False
|
||||
|
||||
openDropdown wenv widgetInst = resultReqs requests newInstance where
|
||||
openDropdown wenv inst = resultReqs requests newInstance where
|
||||
selected = currentValue wenv
|
||||
selectedIdx = fromMaybe 0 (Seq.elemIndexL selected items)
|
||||
newState = DropdownState True
|
||||
newInstance = widgetInst {
|
||||
newInstance = inst {
|
||||
_wiWidget = makeDropdown widgetData items makeMain makeRow config newState
|
||||
}
|
||||
path = _wiPath widgetInst
|
||||
path = _wiPath inst
|
||||
-- listView is wrapped by a scroll
|
||||
lvPath = path |> 0 |> 0
|
||||
requests = [SetOverlay path, SetFocus lvPath]
|
||||
|
||||
closeDropdown wenv widgetInst = resultReqs requests newInstance where
|
||||
path = _wiPath widgetInst
|
||||
closeDropdown wenv inst = resultReqs requests newInstance where
|
||||
path = _wiPath inst
|
||||
newState = DropdownState False
|
||||
newInstance = widgetInst {
|
||||
newInstance = inst {
|
||||
_wiWidget = makeDropdown widgetData items makeMain makeRow config newState
|
||||
}
|
||||
requests = [ResetOverlay, SetFocus path]
|
||||
|
||||
handleMessage wenv target message widgetInst = cast message
|
||||
>>= \(OnChangeMessage idx) -> Seq.lookup idx items
|
||||
>>= \value -> Just $ onChange wenv idx value widgetInst
|
||||
handleMessage wenv target msg inst = cast msg >>= handleLvMsg wenv inst
|
||||
|
||||
onChange wenv idx item widgetInst = result where
|
||||
WidgetResult reqs events newInstance = closeDropdown wenv widgetInst
|
||||
handleLvMsg wenv inst (OnChangeMessage idx) = Seq.lookup idx items
|
||||
>>= \value -> Just $ onChange wenv idx value inst
|
||||
handleLvMsg wenv inst OnListBlur = Just $ closeDropdown wenv inst
|
||||
|
||||
onChange wenv idx item inst = result where
|
||||
WidgetResult reqs events newInstance = closeDropdown wenv inst
|
||||
newReqs = Seq.fromList $ widgetDataSet widgetData item
|
||||
++ _ddcOnChangeReq config
|
||||
++ fmap ($ idx) (_ddcOnChangeIdxReq config)
|
||||
@ -276,13 +279,13 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
++ fmap (\fn -> fn idx item) (_ddcOnChangeIdx config)
|
||||
result = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance
|
||||
|
||||
getSizeReq wenv widgetInst children = sizeReq where
|
||||
style = instanceStyle wenv widgetInst
|
||||
getSizeReq wenv inst children = sizeReq where
|
||||
style = instanceStyle wenv inst
|
||||
Size w h = getTextSize wenv style (dropdownLabel wenv)
|
||||
factor = 1
|
||||
sizeReq = (FlexSize w factor, FixedSize h)
|
||||
|
||||
resize wenv viewport renderArea children widgetInst = resized where
|
||||
resize wenv viewport renderArea children inst = resized where
|
||||
Size winW winH = _weAppWindowSize wenv
|
||||
Rect rx ry rw rh = renderArea
|
||||
dropdownY dh
|
||||
@ -302,9 +305,9 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
}
|
||||
Nothing -> (viewport, renderArea)
|
||||
assignedArea = Seq.singleton area
|
||||
resized = (widgetInst, assignedArea)
|
||||
resized = (inst, assignedArea)
|
||||
|
||||
render renderer wenv widgetInst@WidgetInstance{..} = do
|
||||
render renderer wenv inst@WidgetInstance{..} = do
|
||||
drawStyledBackground renderer renderArea style
|
||||
drawStyledText_ renderer renderArea style (dropdownLabel wenv)
|
||||
|
||||
@ -314,7 +317,7 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
where
|
||||
listViewOverlay = Seq.lookup 0 _wiChildren
|
||||
renderArea = _wiRenderArea
|
||||
style = instanceStyle wenv widgetInst
|
||||
style = instanceStyle wenv inst
|
||||
|
||||
renderOverlay renderer wenv overlayInstance = renderAction where
|
||||
widget = _wiWidget overlayInstance
|
||||
@ -334,6 +337,8 @@ makeListView
|
||||
makeListView value items makeRow config path selected = listViewInst where
|
||||
DropdownCfg{..} = config
|
||||
lvConfig = [
|
||||
selectOnBlur True,
|
||||
onBlurReq (SendMessage path OnListBlur),
|
||||
onChangeIdxReq (SendMessage path . OnChangeMessage),
|
||||
setStyle _ddcSelectedStyle selectedStyle,
|
||||
setStyle _ddcHoverStyle hoverStyle,
|
||||
|
||||
@ -22,6 +22,7 @@ import Data.Sequence (Seq(..), (<|), (|>))
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable (Typeable, cast)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import Monomer.Graphics.Lens
|
||||
@ -35,10 +36,13 @@ import Monomer.Widgets.Stack
|
||||
import qualified Monomer.Core.Lens as L
|
||||
|
||||
data ListViewCfg s e a = ListViewCfg {
|
||||
_lvcOnBlur :: [e],
|
||||
_lvcOnBlurReq :: [WidgetRequest s],
|
||||
_lvcOnChange :: [a -> e],
|
||||
_lvcOnChangeReq :: [WidgetRequest s],
|
||||
_lvcOnChangeIdx :: [Int -> a -> e],
|
||||
_lvcOnChangeIdxReq :: [Int -> WidgetRequest s],
|
||||
_lvcSelectedOnBlur :: Maybe Bool,
|
||||
_lvcSelectedStyle :: Maybe StyleState,
|
||||
_lvcHoverStyle :: Maybe StyleState,
|
||||
_lvcHighlightedColor :: Maybe Color
|
||||
@ -46,10 +50,13 @@ data ListViewCfg s e a = ListViewCfg {
|
||||
|
||||
instance Default (ListViewCfg s e a) where
|
||||
def = ListViewCfg {
|
||||
_lvcOnBlur = [],
|
||||
_lvcOnBlurReq = [],
|
||||
_lvcOnChange = [],
|
||||
_lvcOnChangeReq = [],
|
||||
_lvcOnChangeIdx = [],
|
||||
_lvcOnChangeIdxReq = [],
|
||||
_lvcSelectedOnBlur = Nothing,
|
||||
_lvcSelectedStyle = Just $ bgColor gray,
|
||||
_lvcHoverStyle = Just $ bgColor darkGray,
|
||||
_lvcHighlightedColor = Just lightGray
|
||||
@ -57,10 +64,13 @@ instance Default (ListViewCfg s e a) where
|
||||
|
||||
instance Semigroup (ListViewCfg s e a) where
|
||||
(<>) t1 t2 = ListViewCfg {
|
||||
_lvcOnBlur = _lvcOnBlur t1 <> _lvcOnBlur t2,
|
||||
_lvcOnBlurReq = _lvcOnBlurReq t1 <> _lvcOnBlurReq t2,
|
||||
_lvcOnChange = _lvcOnChange t1 <> _lvcOnChange t2,
|
||||
_lvcOnChangeReq = _lvcOnChangeReq t1 <> _lvcOnChangeReq t2,
|
||||
_lvcOnChangeIdx = _lvcOnChangeIdx t1 <> _lvcOnChangeIdx t2,
|
||||
_lvcOnChangeIdxReq = _lvcOnChangeIdxReq t1 <> _lvcOnChangeIdxReq t2,
|
||||
_lvcSelectedOnBlur = _lvcSelectedOnBlur t2 <|> _lvcSelectedOnBlur t1,
|
||||
_lvcSelectedStyle = _lvcSelectedStyle t2 <|> _lvcSelectedStyle t1,
|
||||
_lvcHoverStyle = _lvcHoverStyle t2 <|> _lvcHoverStyle t1,
|
||||
_lvcHighlightedColor = _lvcHighlightedColor t2 <|> _lvcHighlightedColor t1
|
||||
@ -68,15 +78,28 @@ instance Semigroup (ListViewCfg s e a) where
|
||||
|
||||
instance Monoid (ListViewCfg s e a) where
|
||||
mempty = ListViewCfg {
|
||||
_lvcOnBlur = [],
|
||||
_lvcOnBlurReq = [],
|
||||
_lvcOnChange = [],
|
||||
_lvcOnChangeReq = [],
|
||||
_lvcOnChangeIdx = [],
|
||||
_lvcOnChangeIdxReq = [],
|
||||
_lvcSelectedOnBlur = Nothing,
|
||||
_lvcSelectedStyle = Nothing,
|
||||
_lvcHoverStyle = Nothing,
|
||||
_lvcHighlightedColor = Nothing
|
||||
}
|
||||
|
||||
instance OnBlur (ListViewCfg s e a) e where
|
||||
onBlur fn = def {
|
||||
_lvcOnBlur = [fn]
|
||||
}
|
||||
|
||||
instance OnBlurReq (ListViewCfg s e a) s where
|
||||
onBlurReq req = def {
|
||||
_lvcOnBlurReq = [req]
|
||||
}
|
||||
|
||||
instance OnChange (ListViewCfg s e a) a e where
|
||||
onChange fn = def {
|
||||
_lvcOnChange = [fn]
|
||||
@ -97,6 +120,11 @@ instance OnChangeIdxReq (ListViewCfg s e a) s where
|
||||
_lvcOnChangeIdxReq = [req]
|
||||
}
|
||||
|
||||
instance SelectOnBlur (ListViewCfg s e a) where
|
||||
selectOnBlur select = def {
|
||||
_lvcSelectedOnBlur = Just select
|
||||
}
|
||||
|
||||
instance SelectedStyle (ListViewCfg s e a) where
|
||||
selectedStyle style = def {
|
||||
_lvcSelectedStyle = Just style
|
||||
@ -203,103 +231,115 @@ makeListView widgetData items makeRow config state = widget where
|
||||
|
||||
currentValue wenv = widgetDataGet (_weModel wenv) widgetData
|
||||
|
||||
createListView wenv newState widgetInst = newInstance where
|
||||
createListView wenv newState inst = newInstance where
|
||||
selected = currentValue wenv
|
||||
highlighted = _highlighted newState
|
||||
path = _wiPath widgetInst
|
||||
path = _wiPath inst
|
||||
itemsList = makeItemsList items makeRow config path selected highlighted
|
||||
newInstance = widgetInst {
|
||||
newInstance = inst {
|
||||
_wiWidget = makeListView widgetData items makeRow config newState,
|
||||
_wiChildren = Seq.singleton itemsList
|
||||
}
|
||||
|
||||
init wenv widgetInst = resultWidget $ createListView wenv state widgetInst
|
||||
init wenv inst = resultWidget $ createListView wenv state inst
|
||||
|
||||
merge wenv oldState newInstance = result where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
result = resultWidget $ createListView wenv newState newInstance
|
||||
|
||||
handleEvent wenv target evt widgetInst = case evt of
|
||||
handleEvent wenv target evt inst = case evt of
|
||||
Blur -> result where
|
||||
isTabPressed = getKeyStatus (_weInputStatus wenv) keyTab == KeyPressed
|
||||
changeReq = isTabPressed && fromMaybe False (_lvcSelectedOnBlur config)
|
||||
WidgetResult tempReqs tempEvts tempInst
|
||||
| changeReq = selectItem wenv inst (_highlighted state)
|
||||
| otherwise = resultWidget inst
|
||||
evts = tempEvts <> Seq.fromList (_lvcOnBlur config)
|
||||
reqs = tempReqs <> Seq.fromList (_lvcOnBlurReq config)
|
||||
mergedResult = Just $ WidgetResult reqs evts tempInst
|
||||
result
|
||||
| changeReq || not (null evts && null reqs) = mergedResult
|
||||
| otherwise = Nothing
|
||||
KeyAction mode code status
|
||||
| isKeyDown code && status == KeyPressed -> highlightNext wenv widgetInst
|
||||
| isKeyUp code && status == KeyPressed -> highlightPrev wenv widgetInst
|
||||
| isKeyDown code && status == KeyPressed -> highlightNext wenv inst
|
||||
| isKeyUp code && status == KeyPressed -> highlightPrev wenv inst
|
||||
| isSelectKey code && status == KeyPressed -> resultSelected
|
||||
where
|
||||
resultSelected = Just $ selectItem wenv widgetInst (_highlighted state)
|
||||
resultSelected = Just $ selectItem wenv inst (_highlighted state)
|
||||
isSelectKey code = isKeyReturn code || isKeySpace code
|
||||
_ -> Nothing
|
||||
|
||||
highlightNext wenv widgetInst = highlightItem wenv widgetInst nextIdx where
|
||||
highlightNext wenv inst = highlightItem wenv inst nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
nextIdx
|
||||
| tempIdx < length items - 1 = tempIdx + 1
|
||||
| otherwise = tempIdx
|
||||
|
||||
highlightPrev wenv widgetInst = highlightItem wenv widgetInst nextIdx where
|
||||
highlightPrev wenv inst = highlightItem wenv inst nextIdx where
|
||||
tempIdx = _highlighted state
|
||||
nextIdx
|
||||
| tempIdx > 0 = tempIdx - 1
|
||||
| otherwise = tempIdx
|
||||
|
||||
handleMessage wenv target message widgetInst = result where
|
||||
handleSelect (OnClickMessage idx) = selectItem wenv widgetInst idx
|
||||
handleMessage wenv target message inst = result where
|
||||
handleSelect (OnClickMessage idx) = selectItem wenv inst idx
|
||||
result = fmap handleSelect (cast message)
|
||||
|
||||
highlightItem wenv widgetInst nextIdx = result where
|
||||
highlightItem wenv inst nextIdx = result where
|
||||
newState = ListViewState nextIdx
|
||||
newWidget = makeListView widgetData items makeRow 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 {
|
||||
oldInstance = inst {
|
||||
_wiWidget = 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
|
||||
scrollToReq = itemScrollTo inst nextIdx
|
||||
requests = Seq.fromList scrollToReq
|
||||
result = Just $ widgetResult {
|
||||
_wrRequests = requests,
|
||||
_wrWidget = resizeInstance wenv (_wrWidget widgetResult)
|
||||
}
|
||||
|
||||
selectItem wenv widgetInst idx = result where
|
||||
selectItem wenv inst idx = result where
|
||||
selected = currentValue wenv
|
||||
value = fromMaybe selected (Seq.lookup idx items)
|
||||
valueSetReq = widgetDataSet widgetData value
|
||||
scrollToReq = itemScrollTo widgetInst idx
|
||||
scrollToReq = itemScrollTo inst idx
|
||||
events = fmap ($ value) (_lvcOnChange config)
|
||||
++ fmap (\fn -> fn idx value) (_lvcOnChangeIdx config)
|
||||
changeReqs = _lvcOnChangeReq config
|
||||
++ fmap ($ idx) (_lvcOnChangeIdxReq config)
|
||||
focusReq = [SetFocus $ _wiPath widgetInst]
|
||||
focusReq = [SetFocus $ _wiPath inst]
|
||||
requests = valueSetReq ++ scrollToReq ++ changeReqs ++ focusReq
|
||||
newState = ListViewState idx
|
||||
newInstance = widgetInst {
|
||||
newInstance = inst {
|
||||
_wiWidget = makeListView widgetData items makeRow config newState
|
||||
}
|
||||
result = resultReqsEvents requests events newInstance
|
||||
|
||||
itemScrollTo widgetInst idx = maybeToList (fmap scrollReq renderArea) where
|
||||
renderArea = itemRenderArea widgetInst idx
|
||||
scrollPath = parentPath widgetInst
|
||||
itemScrollTo inst idx = maybeToList (fmap scrollReq renderArea) where
|
||||
renderArea = itemRenderArea inst idx
|
||||
scrollPath = parentPath inst
|
||||
scrollReq rect = SendMessage scrollPath (ScrollTo rect)
|
||||
|
||||
itemRenderArea widgetInst idx = renderArea where
|
||||
itemRenderArea inst idx = renderArea where
|
||||
lookup idx inst = Seq.lookup idx (_wiChildren inst)
|
||||
renderArea = fmap _wiRenderArea $ pure widgetInst
|
||||
renderArea = fmap _wiRenderArea $ pure inst
|
||||
>>= lookup 0 -- vstack
|
||||
>>= lookup idx -- item
|
||||
|
||||
getSizeReq wenv widgetInst children = (newSizeReqW, newSizeReqH) where
|
||||
getSizeReq wenv inst children = (newSizeReqW, newSizeReqH) where
|
||||
child = Seq.index children 0
|
||||
newSizeReqW = _wiSizeReqW child
|
||||
newSizeReqH = _wiSizeReqH child
|
||||
|
||||
resize wenv viewport renderArea children widgetInst = resized where
|
||||
resize wenv viewport renderArea children inst = resized where
|
||||
assignedArea = Seq.singleton (viewport, renderArea)
|
||||
resized = (widgetInst, assignedArea)
|
||||
resized = (inst, assignedArea)
|
||||
|
||||
render renderer wenv inst = do
|
||||
renderWrapper defaultRender renderer wenv inst
|
||||
|
||||
@ -24,14 +24,14 @@ isFocusCandidate FocusBwd = isFocusBwdCandidate
|
||||
|
||||
isFocusFwdCandidate :: Path -> WidgetInstance s e -> Bool
|
||||
isFocusFwdCandidate startFrom widgetInst = isValid where
|
||||
isBefore = isTargetBeforeCurrent startFrom widgetInst
|
||||
isBefore = isTargetBeforeWidget startFrom widgetInst
|
||||
isFocusable = _wiFocusable widgetInst
|
||||
isEnabled = _wiVisible widgetInst && _wiEnabled widgetInst
|
||||
isValid = isBefore && isFocusable && isEnabled
|
||||
|
||||
isFocusBwdCandidate :: Path -> WidgetInstance s e -> Bool
|
||||
isFocusBwdCandidate startFrom widgetInst = isValid where
|
||||
isAfter = isTargetAfterCurrent startFrom widgetInst
|
||||
isAfter = isTargetAfterWidget startFrom widgetInst
|
||||
isFocusable = _wiFocusable widgetInst
|
||||
isEnabled = _wiVisible widgetInst && _wiEnabled widgetInst
|
||||
isValid = isAfter && isFocusable && isEnabled
|
||||
@ -46,8 +46,8 @@ isTargetValid target widgetInst = valid where
|
||||
Just step -> step < Seq.length children
|
||||
Nothing -> False
|
||||
|
||||
isTargetBeforeCurrent :: Path -> WidgetInstance s e -> Bool
|
||||
isTargetBeforeCurrent target widgetInst = result where
|
||||
isTargetBeforeWidget :: Path -> WidgetInstance s e -> Bool
|
||||
isTargetBeforeWidget target widgetInst = result where
|
||||
currentPath = _wiPath widgetInst
|
||||
lenTarget = Seq.length target
|
||||
lenCurrent = Seq.length currentPath
|
||||
@ -56,8 +56,8 @@ isTargetBeforeCurrent target widgetInst = result where
|
||||
| lenTarget > lenCurrent = targetPrefix <= currentPath
|
||||
| otherwise = target < currentPath
|
||||
|
||||
isTargetAfterCurrent :: Path -> WidgetInstance s e -> Bool
|
||||
isTargetAfterCurrent target widgetInst
|
||||
isTargetAfterWidget :: Path -> WidgetInstance s e -> Bool
|
||||
isTargetAfterWidget target widgetInst
|
||||
| target == rootPath = True
|
||||
| otherwise = target > currentPath
|
||||
where
|
||||
|
||||
@ -1,11 +1,20 @@
|
||||
module Monomer.Widgets.Util.Misc where
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Monomer.Core
|
||||
import Monomer.Event
|
||||
|
||||
pointInViewport :: Point -> WidgetInstance s e -> Bool
|
||||
pointInViewport p inst = pointInRect p (_wiViewport inst)
|
||||
|
||||
getKeyStatus :: InputStatus -> KeyCode -> KeyStatus
|
||||
getKeyStatus inputStatus code = status where
|
||||
keys = _ipsKeys inputStatus
|
||||
status = fromMaybe KeyReleased (M.lookup code keys)
|
||||
|
||||
isShortCutControl :: WidgetEnv s e -> KeyMod -> Bool
|
||||
isShortCutControl wenv mod = isControl || isCommand where
|
||||
isControl = not (isMacOS wenv) && _kmLeftCtrl mod
|
||||
|
||||
4
tasks.md
4
tasks.md
@ -231,11 +231,13 @@
|
||||
- Most likely handled as part of style. Discard margins, but consider border + padding
|
||||
- Maybe also add an option like SetOverlay
|
||||
- Handle findNextFocus in zstack (only consider top layer, unless configured otherwise)
|
||||
- Keyboard not working on dropdown
|
||||
|
||||
- Pending
|
||||
- Keyboard not working on dropdown
|
||||
- Add way of ignoring unassigned events in stack (or return nothing on findByPoint)
|
||||
- Make sure that focus change requests do not leave overlay if active (most likely an if clause is needed in handleFocusChange)
|
||||
- Add way of requesting findNextFocus (needed on Dropdown)
|
||||
- Return list of actions instead of Monoid in eventHandler
|
||||
- Use theme for all components
|
||||
- Multiline label
|
||||
- Add testing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user