mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-11-13 00:11:06 +03:00
Reorder fields in WidgetResult, rename helper functions
This commit is contained in:
Francisco Vallarino
parent
9518b2db23
commit
e3b9193906
@ -80,17 +80,18 @@ data WidgetRequest s
|
||||
| forall i . Typeable i => RunProducer Path ((i -> IO ()) -> IO ())
|
||||
|
||||
data WidgetResult s e = WidgetResult {
|
||||
_wrWidget :: WidgetInstance s e,
|
||||
_wrRequests :: Seq (WidgetRequest s),
|
||||
_wrEvents :: Seq e,
|
||||
_wrWidget :: WidgetInstance s e
|
||||
_wrEvents :: Seq e
|
||||
}
|
||||
|
||||
-- This instance is lawless (there is not an empty widget): use with caution
|
||||
instance Semigroup (WidgetResult s e) where
|
||||
er1 <> er2 = WidgetResult reqs evts widget where
|
||||
reqs = _wrRequests er1 <> _wrRequests er2
|
||||
evts = _wrEvents er1 <> _wrEvents er2
|
||||
widget = _wrWidget er2
|
||||
er1 <> er2 = WidgetResult {
|
||||
_wrWidget = _wrWidget er2,
|
||||
_wrRequests = _wrRequests er1 <> _wrRequests er2,
|
||||
_wrEvents = _wrEvents er1 <> _wrEvents er2
|
||||
}
|
||||
|
||||
data WidgetEnv s e = WidgetEnv {
|
||||
_weOS :: Text,
|
||||
|
||||
@ -70,7 +70,7 @@ handleSystemEvent wenv event currentTarget widgetRoot = do
|
||||
Nothing -> return (wenv, Seq.empty, widgetRoot)
|
||||
Just target -> do
|
||||
let widget = _wiWidget widgetRoot
|
||||
let emptyResult = WidgetResult Seq.empty Seq.empty widgetRoot
|
||||
let emptyResult = WidgetResult widgetRoot Seq.empty Seq.empty
|
||||
let evtResult = widgetHandleEvent widget wenv target event widgetRoot
|
||||
let widgetResult = fromMaybe emptyResult evtResult
|
||||
|
||||
@ -114,7 +114,7 @@ handleWidgetResult
|
||||
=> WidgetEnv s e
|
||||
-> WidgetResult s e
|
||||
-> m (HandlerStep s e)
|
||||
handleWidgetResult wenv (WidgetResult reqs events evtRoot) =
|
||||
handleWidgetResult wenv (WidgetResult evtRoot reqs events) =
|
||||
handleRequests reqs (wenv, events, evtRoot)
|
||||
>>= handleResizeWidgets reqs
|
||||
|
||||
@ -309,7 +309,7 @@ handleSendMessage
|
||||
-> HandlerStep s e
|
||||
-> m (HandlerStep s e)
|
||||
handleSendMessage path message (wenv, events, widgetRoot) = do
|
||||
let emptyResult = WidgetResult Seq.empty Seq.empty widgetRoot
|
||||
let emptyResult = WidgetResult widgetRoot Seq.empty Seq.empty
|
||||
let widget = _wiWidget widgetRoot
|
||||
let msgResult = widgetHandleMessage widget wenv path message widgetRoot
|
||||
let widgetResult = fromMaybe emptyResult msgResult
|
||||
|
||||
@ -85,7 +85,7 @@ processTaskEvent
|
||||
processTaskEvent wenv widgetRoot path event = do
|
||||
currentFocus <- use pathFocus
|
||||
|
||||
let emptyResult = WidgetResult Seq.empty Seq.empty widgetRoot
|
||||
let emptyResult = WidgetResult widgetRoot Seq.empty Seq.empty
|
||||
let widget = _wiWidget widgetRoot
|
||||
let msgResult = widgetHandleMessage widget wenv path event widgetRoot
|
||||
let widgetResult = fromMaybe emptyResult msgResult
|
||||
|
||||
@ -139,7 +139,7 @@ makeBox config = widget where
|
||||
| otherwise = _boxOnClickEmptyReq config
|
||||
needsUpdate = btn == LeftBtn && not (null events && null requests)
|
||||
result
|
||||
| needsUpdate = Just $ resultReqsEvents requests events inst
|
||||
| needsUpdate = Just $ resultReqsEvts inst requests events
|
||||
| otherwise = Nothing
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
@ -208,7 +208,7 @@ makeButton config state = widget where
|
||||
where
|
||||
requests = _btnOnClickReq config
|
||||
events = _btnOnClick config
|
||||
result = resultReqsEvents requests events inst
|
||||
result = resultReqsEvts inst requests events
|
||||
|
||||
getSizeReq wenv inst = (sizeW, sizeH) where
|
||||
style = activeStyle wenv inst
|
||||
|
||||
@ -131,9 +131,9 @@ makeCheckbox widgetData config = widget where
|
||||
Focus -> handleFocusChange _ckcOnFocus _ckcOnFocusReq config inst
|
||||
Blur -> handleFocusChange _ckcOnBlur _ckcOnBlurReq config inst
|
||||
Click p _
|
||||
| pointInViewport p inst -> Just $ resultReqsEvents clickReqs events inst
|
||||
| pointInViewport p inst -> Just $ resultReqsEvts inst clickReqs events
|
||||
KeyAction mod code KeyPressed
|
||||
| isSelectKey code -> Just $ resultReqsEvents reqs events inst
|
||||
| isSelectKey code -> Just $ resultReqsEvts inst reqs events
|
||||
_ -> Nothing
|
||||
where
|
||||
isSelectKey code = isKeyReturn code || isKeySpace code
|
||||
|
||||
@ -236,14 +236,14 @@ compositeInit comp state wenv widgetComp = newResult where
|
||||
-- Creates UI using provided function
|
||||
builtRoot = _cmpUiBuilder comp model
|
||||
tempRoot = cascadeCtx widgetComp builtRoot
|
||||
WidgetResult reqs evts root = widgetInit (_wiWidget tempRoot) cwenv tempRoot
|
||||
WidgetResult root reqs evts = widgetInit (_wiWidget tempRoot) cwenv tempRoot
|
||||
newEvts = maybe evts (evts |>) (_cmpInitEvent comp)
|
||||
newState = state {
|
||||
_cpsModel = Just model,
|
||||
_cpsRoot = root,
|
||||
_cpsGlobalKeys = collectGlobalKeys M.empty root
|
||||
}
|
||||
tempResult = WidgetResult reqs newEvts root
|
||||
tempResult = WidgetResult root reqs newEvts
|
||||
getBaseStyle wenv inst = Nothing
|
||||
styledComp = initInstanceStyle getBaseStyle wenv widgetComp
|
||||
newResult = reduceResult comp newState wenv styledComp tempResult
|
||||
@ -303,8 +303,8 @@ compositeDispose comp state wenv widgetComp = result where
|
||||
model = getModel comp wenv
|
||||
cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
|
||||
widget = _wiWidget _cpsRoot
|
||||
WidgetResult reqs evts _ = widgetDispose widget cwenv _cpsRoot
|
||||
tempResult = WidgetResult reqs evts _cpsRoot
|
||||
WidgetResult _ reqs evts = widgetDispose widget cwenv _cpsRoot
|
||||
tempResult = WidgetResult _cpsRoot reqs evts
|
||||
result = reduceResult comp state wenv widgetComp tempResult
|
||||
|
||||
-- | Next focusable
|
||||
@ -382,7 +382,7 @@ compositeHandleMessage
|
||||
compositeHandleMessage comp state@CompositeState{..} wenv target arg widgetComp
|
||||
| isTargetReached target widgetComp = case cast arg of
|
||||
Just (Just evt) -> reducedResult where
|
||||
evtResult = WidgetResult Seq.empty (Seq.singleton evt) _cpsRoot
|
||||
evtResult = WidgetResult _cpsRoot Seq.empty (Seq.singleton evt)
|
||||
reducedResult = Just $ reduceResult comp state wenv widgetComp evtResult
|
||||
_ -> Nothing
|
||||
| otherwise = fmap processEvent result where
|
||||
@ -475,7 +475,7 @@ reduceResult
|
||||
-> WidgetResult sp ep
|
||||
reduceResult comp state wenv widgetComp widgetResult = newResult where
|
||||
CompositeState{..} = state
|
||||
WidgetResult reqs evts evtsRoot = widgetResult
|
||||
WidgetResult evtsRoot reqs evts = widgetResult
|
||||
-- Since composite may reduce several times before giving control back, its
|
||||
-- copy of _cpsModel may be more up to date than WidgetEnv's model
|
||||
model
|
||||
@ -485,7 +485,7 @@ reduceResult comp state wenv widgetComp widgetResult = newResult where
|
||||
evtModel = foldr (.) id evtUpdates model
|
||||
evtHandler = _cmpEventHandler comp
|
||||
ReducedEvents{..} = reduceCompEvents _cpsGlobalKeys evtHandler evtModel evts
|
||||
WidgetResult uReqs uEvts uWidget =
|
||||
WidgetResult uWidget uReqs uEvts =
|
||||
updateComposite comp state wenv _reModel evtsRoot widgetComp
|
||||
currentPath = _wiPath widgetComp
|
||||
newReqs = toParentReqs reqs
|
||||
@ -495,7 +495,7 @@ reduceResult comp state wenv widgetComp widgetResult = newResult where
|
||||
<> toParentReqs _reRequests
|
||||
<> _reMessages
|
||||
newEvts = _reReports <> uEvts
|
||||
newResult = WidgetResult newReqs newEvts uWidget
|
||||
newResult = WidgetResult uWidget newReqs newEvts
|
||||
|
||||
updateComposite
|
||||
:: (CompositeModel s, CompositeEvent e, ParentModel sp)
|
||||
|
||||
@ -214,7 +214,7 @@ initWrapper container wenv inst = result where
|
||||
initHandler = containerInit container
|
||||
getBaseStyle = containerGetBaseStyle container
|
||||
styledInst = initInstanceStyle getBaseStyle wenv inst
|
||||
WidgetResult reqs events tempInst = initHandler wenv styledInst
|
||||
WidgetResult tempInst reqs events = initHandler wenv styledInst
|
||||
children = _wiChildren tempInst
|
||||
initChild idx child = widgetInit newWidget wenv newChild where
|
||||
newChild = cascadeCtx tempInst child idx
|
||||
@ -226,7 +226,7 @@ initWrapper container wenv inst = result where
|
||||
newInst = tempInst {
|
||||
_wiChildren = newChildren
|
||||
}
|
||||
result = WidgetResult (reqs <> newReqs) (events <> newEvents) newInst
|
||||
result = WidgetResult newInst (reqs <> newReqs) (events <> newEvents)
|
||||
|
||||
-- | Merging
|
||||
defaultMerge :: ContainerMergeHandler s e
|
||||
@ -268,7 +268,7 @@ mergeChildren
|
||||
-> WidgetResult s e
|
||||
-> WidgetResult s e
|
||||
mergeChildren wenv oldInst result = newResult where
|
||||
WidgetResult uReqs uEvents uInst = result
|
||||
WidgetResult uInst uReqs uEvents = result
|
||||
oldChildren = _wiChildren oldInst
|
||||
updatedChildren = _wiChildren uInst
|
||||
mergeChild idx child = cascadeCtx uInst child idx
|
||||
@ -286,7 +286,7 @@ mergeChildren wenv oldInst result = newResult where
|
||||
}
|
||||
newReqs = uReqs <> mergedReqs <> removedReqs
|
||||
newEvents = uEvents <> mergedEvents <> removedEvents
|
||||
newResult = WidgetResult newReqs newEvents mergedInst
|
||||
newResult = WidgetResult mergedInst newReqs newEvents
|
||||
|
||||
mergeChildrenSeq
|
||||
:: WidgetEnv s e
|
||||
@ -338,13 +338,13 @@ disposeWrapper
|
||||
-> WidgetResult s e
|
||||
disposeWrapper container wenv inst = result where
|
||||
disposeHandler = containerDispose container
|
||||
WidgetResult reqs events tempInst = disposeHandler wenv inst
|
||||
WidgetResult tempInst reqs events = disposeHandler wenv inst
|
||||
children = _wiChildren tempInst
|
||||
dispose child = widgetDispose (_wiWidget child) wenv child
|
||||
results = fmap dispose children
|
||||
newReqs = fold $ fmap _wrRequests results
|
||||
newEvents = fold $ fmap _wrEvents results
|
||||
result = WidgetResult (reqs <> newReqs) (events <> newEvents) inst
|
||||
result = WidgetResult inst (reqs <> newReqs) (events <> newEvents)
|
||||
|
||||
-- | State Handling helpers
|
||||
defaultGetState :: ContainerGetStateHandler s e
|
||||
@ -478,7 +478,7 @@ mergeParentChildEvts original Nothing (Just cResponse) idx = Just $ cResponse {
|
||||
mergeParentChildEvts original (Just pResponse) (Just cResponse) idx
|
||||
| ignoreChildren pResponse = Just pResponse
|
||||
| ignoreParent cResponse = Just newChildResponse
|
||||
| otherwise = Just $ WidgetResult requests userEvents newWidget
|
||||
| otherwise = Just $ WidgetResult newWidget requests userEvents
|
||||
where
|
||||
pWidget = _wrWidget pResponse
|
||||
cWidget = _wrWidget cResponse
|
||||
|
||||
@ -215,14 +215,14 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
isOpen = _isOpen state
|
||||
currentValue wenv = widgetDataGet (_weModel wenv) widgetData
|
||||
|
||||
createDropdown wenv newState inst = newInstance where
|
||||
createDropdown wenv newState inst = newInst where
|
||||
selected = currentValue wenv
|
||||
mainStyle = collectTheme wenv L.dropdownStyle
|
||||
mainInst = makeMain selected & L.style .~ mainStyle
|
||||
path = _wiPath inst
|
||||
listViewInst = makeListView wenv widgetData items makeRow config path
|
||||
newWidget = makeDropdown widgetData items makeMain makeRow config newState
|
||||
newInstance = inst {
|
||||
newInst = inst {
|
||||
_wiWidget = newWidget,
|
||||
_wiChildren = Seq.fromList [mainInst, listViewInst]
|
||||
}
|
||||
@ -250,7 +250,7 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
| isKeyEscape code && isOpen -> Just $ closeDropdown wenv inst
|
||||
where isKeyOpenDropdown = isKeyDown code || isKeyUp code
|
||||
_
|
||||
| not isOpen -> Just $ resultReqs [IgnoreChildrenEvents] inst
|
||||
| not isOpen -> Just $ resultReqs inst [IgnoreChildrenEvents]
|
||||
| otherwise -> Nothing
|
||||
|
||||
openRequired point inst = not isOpen && inViewport where
|
||||
@ -261,11 +261,11 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
Just inst -> pointInRect point (_wiViewport inst)
|
||||
Nothing -> False
|
||||
|
||||
openDropdown wenv inst = resultReqs requests newInstance where
|
||||
openDropdown wenv inst = resultReqs newInst requests where
|
||||
selected = currentValue wenv
|
||||
selectedIdx = fromMaybe 0 (Seq.elemIndexL selected items)
|
||||
newState = DropdownState True
|
||||
newInstance = inst {
|
||||
newInst = inst {
|
||||
_wiWidget = makeDropdown widgetData items makeMain makeRow config newState
|
||||
}
|
||||
path = _wiPath inst
|
||||
@ -273,10 +273,10 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
lvPath = path |> listIdx |> 0
|
||||
requests = [SetOverlay path, SetFocus lvPath]
|
||||
|
||||
closeDropdown wenv inst = resultReqs requests newInstance where
|
||||
closeDropdown wenv inst = resultReqs newInst requests where
|
||||
path = _wiPath inst
|
||||
newState = DropdownState False
|
||||
newInstance = inst {
|
||||
newInst = inst {
|
||||
_wiWidget = makeDropdown widgetData items makeMain makeRow config newState
|
||||
}
|
||||
requests = [ResetOverlay, SetFocus path]
|
||||
@ -293,13 +293,13 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
|
||||
}
|
||||
|
||||
onChange wenv idx item inst = result where
|
||||
WidgetResult reqs events newInstance = closeDropdown wenv inst
|
||||
WidgetResult newInst reqs events = closeDropdown wenv inst
|
||||
newReqs = Seq.fromList $ widgetDataSet widgetData item
|
||||
++ _ddcOnChangeReq config
|
||||
++ fmap ($ idx) (_ddcOnChangeIdxReq config)
|
||||
newEvents = Seq.fromList $ fmap ($ item) (_ddcOnChange config)
|
||||
++ fmap (\fn -> fn idx item) (_ddcOnChangeIdx config)
|
||||
result = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance
|
||||
result = WidgetResult newInst (reqs <> newReqs) (events <> newEvents)
|
||||
|
||||
getSizeReq wenv inst children = sizeReq where
|
||||
child = Seq.index children 0
|
||||
|
||||
@ -120,7 +120,7 @@ makeImage imgPath config state = widget where
|
||||
singleRender = render
|
||||
}
|
||||
|
||||
init wenv inst = resultReqs reqs inst where
|
||||
init wenv inst = resultReqs inst reqs where
|
||||
path = _wiPath inst
|
||||
reqs = [RunTask path $ handleImageLoad wenv imgPath]
|
||||
|
||||
@ -136,9 +136,9 @@ makeImage imgPath config state = widget where
|
||||
}
|
||||
result
|
||||
| isImagePath newState == imgPath = resultWidget sameImgInst
|
||||
| otherwise = resultReqs newImgReqs inst
|
||||
| otherwise = resultReqs inst newImgReqs
|
||||
|
||||
dispose wenv inst = resultReqs reqs inst where
|
||||
dispose wenv inst = resultReqs inst reqs where
|
||||
path = _wiPath inst
|
||||
renderer = _weRenderer wenv
|
||||
reqs = [RunTask path $ removeImage wenv imgPath]
|
||||
@ -148,12 +148,12 @@ makeImage imgPath config state = widget where
|
||||
|
||||
useImage inst (ImageFailed msg) = result where
|
||||
evts = fmap ($ msg) (_imcLoadError config)
|
||||
result = Just $ resultEvents evts inst
|
||||
result = Just $ resultEvts inst evts
|
||||
useImage inst (ImageLoaded newState) = result where
|
||||
newInst = inst {
|
||||
_wiWidget = makeImage imgPath config newState
|
||||
}
|
||||
result = Just $ resultReqs [ResizeWidgets] newInst
|
||||
result = Just $ resultReqs newInst [ResizeWidgets]
|
||||
|
||||
getSizeReq wenv inst = sizeReq where
|
||||
style = activeStyle wenv inst
|
||||
|
||||
@ -111,16 +111,17 @@ makeInputField config state = widget where
|
||||
getBaseStyle wenv inst = _ifcStyle config >>= handler where
|
||||
handler lstyle = Just $ collectTheme wenv (cloneLens lstyle)
|
||||
|
||||
init wenv inst = resultReqs reqs newInstance where
|
||||
init wenv inst = result where
|
||||
newValue = getModelValue wenv
|
||||
newState = newTextState wenv inst state newValue (toText newValue) 0 Nothing
|
||||
newInstance = inst {
|
||||
newInst = inst {
|
||||
_wiWidget = makeInputField config newState
|
||||
}
|
||||
parsedVal = fromText (toText newValue)
|
||||
reqs = setModelValid (isJust parsedVal)
|
||||
result = resultReqs newInst reqs
|
||||
|
||||
merge wenv oldState oldInst inst = resultReqs reqs newInstance where
|
||||
merge wenv oldState oldInst inst = resultReqs newInst reqs where
|
||||
currState = fromMaybe state (useState oldState)
|
||||
oldValue = _ifsCurrValue currState
|
||||
oldText = _ifsCurrText currState
|
||||
@ -138,7 +139,7 @@ makeInputField config state = widget where
|
||||
| isNothing oldSel || newTextL < fromJust oldSel = Nothing
|
||||
| otherwise = oldSel
|
||||
newState = newTextState wenv inst currState value newText newPos newSelStart
|
||||
newInstance = inst {
|
||||
newInst = inst {
|
||||
_wiWidget = makeInputField config newState
|
||||
}
|
||||
parsedVal = fromText newText
|
||||
@ -150,7 +151,7 @@ makeInputField config state = widget where
|
||||
| otherwise = []
|
||||
reqs = setModelValid (isJust parsedVal) ++ renderReqs
|
||||
|
||||
dispose wenv inst = resultReqs reqs inst where
|
||||
dispose wenv inst = resultReqs inst reqs where
|
||||
path = _wiPath inst
|
||||
reqs = [ RenderStop path ]
|
||||
|
||||
@ -268,7 +269,7 @@ makeInputField config state = widget where
|
||||
}
|
||||
result
|
||||
| isFocused wenv inst = Just $ resultWidget newInst
|
||||
| otherwise = Just $ resultReqs [SetFocus $ _wiPath inst] newInst
|
||||
| otherwise = Just $ resultReqs newInst [SetFocus $ _wiPath inst]
|
||||
|
||||
KeyAction mod code KeyPressed -> result where
|
||||
isPaste = isClipboardPaste wenv evt
|
||||
@ -281,7 +282,7 @@ makeInputField config state = widget where
|
||||
result = genInputResult wenv inst False newText newPos newSel clipReqs
|
||||
result
|
||||
| isJust keyRes = Just $ handleKeyRes (fromJust keyRes)
|
||||
| not (null clipReqs) = Just $ resultReqs clipReqs inst
|
||||
| not (null clipReqs) = Just $ resultReqs inst clipReqs
|
||||
| otherwise = Nothing
|
||||
|
||||
TextInput newText -> insertText wenv inst newText
|
||||
@ -301,16 +302,16 @@ makeInputField config state = widget where
|
||||
path = _wiPath inst
|
||||
viewport = _wiViewport inst
|
||||
reqs = [RenderEvery path caretMs, StartTextInput viewport]
|
||||
newResult = resultReqs reqs newInst
|
||||
newResult = resultReqs newInst reqs
|
||||
focusResult = handleFocusChange _ifcOnFocus _ifcOnFocusReq config newInst
|
||||
result = maybe newResult (mergeResults newResult) focusResult
|
||||
result = maybe newResult (newResult <>) focusResult
|
||||
|
||||
Blur -> Just result where
|
||||
path = _wiPath inst
|
||||
reqs = [RenderStop path, StopTextInput]
|
||||
newResult = resultReqs reqs inst
|
||||
newResult = resultReqs inst reqs
|
||||
blurResult = handleFocusChange _ifcOnBlur _ifcOnBlurReq config inst
|
||||
result = maybe newResult (mergeResults newResult) blurResult
|
||||
result = maybe newResult (newResult <>) blurResult
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
@ -356,12 +357,12 @@ makeInputField config state = widget where
|
||||
| otherwise = []
|
||||
reqs = newReqs ++ reqValid ++ reqUpdateModel ++ reqOnChange
|
||||
newState = newTextState wenv inst state stateVal newText newPos newSel
|
||||
newInstance = inst {
|
||||
newInst = inst {
|
||||
_wiWidget = makeInputField config newState
|
||||
}
|
||||
result
|
||||
| isValid || not textAdd = resultReqsEvents reqs events newInstance
|
||||
| otherwise = resultReqsEvents reqs events inst
|
||||
| isValid || not textAdd = resultReqsEvts newInst reqs events
|
||||
| otherwise = resultReqsEvts inst reqs events
|
||||
|
||||
getSizeReq wenv inst = sizeReq where
|
||||
style = activeStyle wenv inst
|
||||
|
||||
@ -124,9 +124,10 @@ makeLabel config state = widget where
|
||||
_lstTextRect = newRect
|
||||
}
|
||||
reqs = [ ResizeWidgets | captionChanged ]
|
||||
result = resultReqs reqs newInst {
|
||||
resInst = newInst {
|
||||
_wiWidget = makeLabel config newState
|
||||
}
|
||||
result = resultReqs resInst reqs
|
||||
|
||||
getSizeReq wenv inst = (sizeW, sizeH) where
|
||||
style = activeStyle wenv inst
|
||||
|
||||
@ -300,12 +300,12 @@ makeListView widgetData items makeRow config state = widget where
|
||||
Blur -> result where
|
||||
isTabPressed = getKeyStatus (_weInputStatus wenv) keyTab == KeyPressed
|
||||
changeReq = isTabPressed && _lvcSelectOnBlur config == Just True
|
||||
WidgetResult tempReqs tempEvts tempInst
|
||||
WidgetResult tempInst tempReqs tempEvts
|
||||
| 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
|
||||
mergedResult = Just $ WidgetResult tempInst reqs evts
|
||||
result
|
||||
| changeReq || not (null evts && null reqs) = mergedResult
|
||||
| otherwise = Nothing
|
||||
@ -349,7 +349,7 @@ makeListView widgetData items makeRow config state = widget where
|
||||
_wiWidget = makeListView widgetData items makeRow config newState
|
||||
}
|
||||
reqs = itemScrollTo inst nextIdx
|
||||
result = resultReqs reqs newInst
|
||||
result = resultReqs newInst reqs
|
||||
|
||||
selectItem wenv inst idx = result where
|
||||
selected = currentValue wenv
|
||||
@ -368,7 +368,7 @@ makeListView widgetData items makeRow config state = widget where
|
||||
newInst = inst {
|
||||
_wiWidget = makeListView widgetData items makeRow config newState
|
||||
}
|
||||
result = resultReqsEvents requests events newInst
|
||||
result = resultReqsEvts newInst requests events
|
||||
|
||||
itemScrollTo inst idx = maybeToList (fmap scrollReq renderArea) where
|
||||
renderArea = itemRenderArea inst idx
|
||||
|
||||
@ -148,9 +148,9 @@ makeRadio field option config = widget where
|
||||
Focus -> handleFocusChange _rdcOnFocus _rdcOnFocusReq config inst
|
||||
Blur -> handleFocusChange _rdcOnBlur _rdcOnBlurReq config inst
|
||||
Click p _
|
||||
| pointInEllipse p rdArea -> Just $ resultReqsEvents clickReqs events inst
|
||||
| pointInEllipse p rdArea -> Just $ resultReqsEvts inst clickReqs events
|
||||
KeyAction mod code KeyPressed
|
||||
| isSelectKey code -> Just $ resultReqsEvents reqs events inst
|
||||
| isSelectKey code -> Just $ resultReqsEvts inst reqs events
|
||||
_ -> Nothing
|
||||
where
|
||||
rdArea = getRadioArea wenv inst config
|
||||
|
||||
@ -174,9 +174,9 @@ makeScroll config state = widget where
|
||||
getBaseStyle wenv inst = _scStyle config >>= handler where
|
||||
handler lstyle = Just $ collectTheme wenv (cloneLens lstyle)
|
||||
|
||||
merge wenv oldState oldInst inst = resultWidget newInstance where
|
||||
merge wenv oldState oldInst inst = resultWidget newInst where
|
||||
newState = fromMaybe state (useState oldState)
|
||||
newInstance = inst {
|
||||
newInst = inst {
|
||||
_wiWidget = makeScroll config newState
|
||||
}
|
||||
|
||||
@ -195,8 +195,8 @@ makeScroll config state = widget where
|
||||
| jumpScrollV = updateScrollThumb state VBar point contentArea sctx
|
||||
| btnReleased = state { _sstDragging = Nothing }
|
||||
| otherwise = state
|
||||
newInstance = rebuildWidget wenv newState inst
|
||||
handledResult = Just $ resultReqs scrollReqs newInstance
|
||||
newInst = rebuildWidget wenv newState inst
|
||||
handledResult = Just $ resultReqs newInst scrollReqs
|
||||
result
|
||||
| leftPressed && (hMouseInThumb || vMouseInThumb) = handledResult
|
||||
| btnReleased && (hMouseInScroll || vMouseInScroll) = handledResult
|
||||
@ -205,14 +205,14 @@ makeScroll config state = widget where
|
||||
Move point -> result where
|
||||
drag bar = updateScrollThumb state bar point contentArea sctx
|
||||
makeWidget state = rebuildWidget wenv state inst
|
||||
makeResult state = resultReqs (RenderOnce : scrollReqs) (makeWidget state)
|
||||
makeResult state = resultReqs (makeWidget state) (RenderOnce : scrollReqs)
|
||||
result = fmap (makeResult . drag) dragging
|
||||
WheelScroll _ (Point wx wy) wheelDirection -> result where
|
||||
changedX = wx /= 0 && childWidth > cw
|
||||
changedY = wy /= 0 && childHeight > ch
|
||||
needsUpdate = changedX || changedY
|
||||
makeWidget state = rebuildWidget wenv state inst
|
||||
makeResult state = resultReqs scrollReqs (makeWidget state)
|
||||
makeResult state = resultReqs (makeWidget state) scrollReqs
|
||||
result
|
||||
| needsUpdate = Just $ makeResult newState
|
||||
| otherwise = Nothing
|
||||
@ -266,10 +266,10 @@ makeScroll config state = widget where
|
||||
_sstDeltaX = scrollAxis stepX childWidth cw,
|
||||
_sstDeltaY = scrollAxis stepY childHeight ch
|
||||
}
|
||||
newInstance = rebuildWidget wenv newState inst
|
||||
newInst = rebuildWidget wenv newState inst
|
||||
result
|
||||
| rectInRect rect contentArea = Nothing
|
||||
| otherwise = Just $ resultWidget newInstance
|
||||
| otherwise = Just $ resultWidget newInst
|
||||
|
||||
updateScrollThumb state activeBar point contentArea sctx = newState where
|
||||
Point px py = point
|
||||
|
||||
@ -7,10 +7,9 @@ module Monomer.Widgets.Util.Widget (
|
||||
widgetDataGet,
|
||||
widgetDataSet,
|
||||
resultWidget,
|
||||
resultEvents,
|
||||
resultEvts,
|
||||
resultReqs,
|
||||
resultReqsEvents,
|
||||
mergeResults,
|
||||
resultReqsEvts,
|
||||
makeState,
|
||||
useState,
|
||||
instanceMatches,
|
||||
@ -73,26 +72,20 @@ widgetDataSet (WidgetLens lens) value = [UpdateModel updateFn] where
|
||||
updateFn model = model & lens #~ value
|
||||
|
||||
resultWidget :: WidgetInstance s e -> WidgetResult s e
|
||||
resultWidget inst = WidgetResult Seq.empty Seq.empty inst
|
||||
resultWidget inst = WidgetResult inst Seq.empty Seq.empty
|
||||
|
||||
resultEvents :: [e] -> WidgetInstance s e -> WidgetResult s e
|
||||
resultEvents events inst = result where
|
||||
result = WidgetResult Seq.empty (Seq.fromList events) inst
|
||||
resultEvts :: WidgetInstance s e -> [e] -> WidgetResult s e
|
||||
resultEvts inst events = result where
|
||||
result = WidgetResult inst Seq.empty (Seq.fromList events)
|
||||
|
||||
resultReqs :: [WidgetRequest s] -> WidgetInstance s e -> WidgetResult s e
|
||||
resultReqs requests inst = result where
|
||||
result = WidgetResult (Seq.fromList requests) Seq.empty inst
|
||||
resultReqs :: WidgetInstance s e -> [WidgetRequest s] -> WidgetResult s e
|
||||
resultReqs inst requests = result where
|
||||
result = WidgetResult inst (Seq.fromList requests) Seq.empty
|
||||
|
||||
resultReqsEvents
|
||||
:: [WidgetRequest s] -> [e] -> WidgetInstance s e -> WidgetResult s e
|
||||
resultReqsEvents requests events inst = result where
|
||||
result = WidgetResult (Seq.fromList requests) (Seq.fromList events) inst
|
||||
|
||||
mergeResults :: WidgetResult s e -> WidgetResult s e -> WidgetResult s e
|
||||
mergeResults res1 res2 = newRes where
|
||||
WidgetResult reqs1 evts1 inst1 = res1
|
||||
WidgetResult reqs2 evts2 inst2 = res2
|
||||
newRes = WidgetResult (reqs1 <> reqs2) (evts1 <> evts2) inst2
|
||||
resultReqsEvts
|
||||
:: WidgetInstance s e -> [WidgetRequest s] -> [e] -> WidgetResult s e
|
||||
resultReqsEvts inst requests events = result where
|
||||
result = WidgetResult inst (Seq.fromList requests) (Seq.fromList events)
|
||||
|
||||
makeState :: Typeable i => i -> s -> Maybe WidgetState
|
||||
makeState state model = Just (WidgetState state)
|
||||
@ -123,5 +116,5 @@ handleFocusChange evtFn reqFn config inst = result where
|
||||
evts = evtFn config
|
||||
reqs = reqFn config
|
||||
result
|
||||
| not (null evts && null reqs) = Just $ resultReqsEvents reqs evts inst
|
||||
| not (null evts && null reqs) = Just $ resultReqsEvts inst reqs evts
|
||||
| otherwise = Nothing
|
||||
|
||||
16
tasks.md
16
tasks.md
@ -297,6 +297,7 @@
|
||||
- The issue was in zstack, where changing visible items should generate a resize request
|
||||
- Review composite initialization. View creation can be moved to init
|
||||
- Check if passing model directly is still correct
|
||||
- Test nested composites
|
||||
|
||||
- Pending
|
||||
- Add testing
|
||||
@ -314,7 +315,20 @@
|
||||
- Add user documentation
|
||||
|
||||
Maybe postponed after release?
|
||||
- Test nested composites
|
||||
- Change interfaces
|
||||
- ??? Change WidgetResult so WidgetInstance is Maybe
|
||||
- ??? This allows having a Default instance and later use lenses instead of the resultX functions
|
||||
- ??? Remove Maybe from handleEvent/handleMessage return type
|
||||
- Change return type and the moment when widgetUpdateSizeReq is called
|
||||
- Comment GlobalKeys out and have Container use its local list of children for merging
|
||||
- Create WidgetNode type, move Widget/children into it
|
||||
- Remove type constraints on WidgetInstance
|
||||
- Change type signatures to use WidgetNode
|
||||
- Restore GlobalKeys
|
||||
- Add method to collect tree of WidgetInstances
|
||||
- Also return map of GlobalKeys, whose value is an existential wrapping the WidgetNode
|
||||
- This is necessary because s/e types may not match
|
||||
- Remove children from WidgetNode
|
||||
- Split WidgetInstance into Definition and Instance, in order to:
|
||||
- Be able to get information about the whole widget tree, even hidden items (inside composite)
|
||||
- This is needed for testing composite
|
||||
|
||||
@ -124,14 +124,14 @@ mockWenvEvtUnit model = mockWenv model
|
||||
|
||||
instInit :: WidgetEnv s e -> WidgetInstance s e -> WidgetInstance s e
|
||||
instInit wenv inst = newInst where
|
||||
WidgetResult _ _ inst2 = widgetInit (_wiWidget inst) wenv inst
|
||||
WidgetResult inst2 _ _ = widgetInit (_wiWidget inst) wenv inst
|
||||
Size w h = _weAppWindowSize wenv
|
||||
vp = Rect 0 0 w h
|
||||
newInst = instResize wenv vp inst2
|
||||
|
||||
instUpdateSizeReq :: WidgetEnv s e -> WidgetInstance s e -> (SizeReq, SizeReq)
|
||||
instUpdateSizeReq wenv inst = (sizeReqW, sizeReqH) where
|
||||
WidgetResult _ _ inst2 = widgetInit (_wiWidget inst) wenv inst
|
||||
WidgetResult inst2 _ _ = widgetInit (_wiWidget inst) wenv inst
|
||||
reqInst = widgetUpdateSizeReq (_wiWidget inst2) wenv inst2
|
||||
sizeReqW = _wiSizeReqW reqInst
|
||||
sizeReqH = _wiSizeReqH reqInst
|
||||
|
||||
@ -32,9 +32,9 @@ initMergeWidget = describe "init/merge" $ do
|
||||
inst1 = image "assets/images/beach.jpg"
|
||||
inst2 = image "assets/images/beach.jpg"
|
||||
inst3 = image "assets/images/beach2.jpg"
|
||||
WidgetResult reqs1 _ newInst1 = widgetInit (_wiWidget inst1) wenv inst1
|
||||
WidgetResult reqs2 _ _ = widgetMerge (_wiWidget inst2) wenv newInst1 inst2
|
||||
WidgetResult reqs3 _ _ = widgetMerge (_wiWidget inst3) wenv newInst1 inst3
|
||||
WidgetResult newInst1 reqs1 _ = widgetInit (_wiWidget inst1) wenv inst1
|
||||
WidgetResult _ reqs2 _ = widgetMerge (_wiWidget inst2) wenv newInst1 inst2
|
||||
WidgetResult _ reqs3 _ = widgetMerge (_wiWidget inst3) wenv newInst1 inst3
|
||||
|
||||
isRunTask :: WidgetRequest s -> Bool
|
||||
isRunTask RunTask{} = True
|
||||
|
||||
Loading…
Reference in New Issue
Block a user