mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-11-10 01:15:49 +03:00
Accumulate requests in WidgetStep, to be able to validate them in tests (ignored by main)
This commit is contained in:
Francisco Vallarino
parent
273742ce1a
commit
289993f569
@ -121,6 +121,27 @@ data WidgetRequest s
|
||||
| forall i . Typeable i => RunTask WidgetId Path (IO i)
|
||||
| forall i . Typeable i => RunProducer WidgetId Path ((i -> IO ()) -> IO ())
|
||||
|
||||
instance Eq (WidgetRequest s) where
|
||||
IgnoreParentEvents == IgnoreParentEvents = True
|
||||
IgnoreChildrenEvents == IgnoreChildrenEvents = True
|
||||
ResizeWidgets == ResizeWidgets = True
|
||||
MoveFocus p1 fd1 == MoveFocus p2 fd2 = (p1, fd1) == (p2, fd2)
|
||||
SetFocus p1 == SetFocus p2 = p1 == p2
|
||||
GetClipboard p1 == GetClipboard p2 = p1 == p2
|
||||
SetClipboard c1 == SetClipboard c2 = c1 == c2
|
||||
StartTextInput r1 == StartTextInput r2 = r1 == r2
|
||||
StopTextInput == StopTextInput = True
|
||||
SetOverlay p1 == SetOverlay p2 = p1 == p2
|
||||
ResetOverlay == ResetOverlay = True
|
||||
SetCursorIcon c1 == SetCursorIcon c2 = c1 == c2
|
||||
RenderOnce == RenderOnce = True
|
||||
RenderEvery p1 c1 r1 == RenderEvery p2 c2 r2 = (p1, c1, r1) == (p2, c2, r2)
|
||||
RenderStop p1 == RenderStop p2 = p1 == p2
|
||||
ExitApplication e1 == ExitApplication e2 = e1 == e2
|
||||
UpdateWindow w1 == UpdateWindow w2 = w1 == w2
|
||||
UpdateWidgetPath w1 p1 == UpdateWidgetPath w2 p2 = (w1, p1) == (w2, p2)
|
||||
_ == _ = False
|
||||
|
||||
data WidgetResult s e = WidgetResult {
|
||||
_wrNode :: WidgetNode s e,
|
||||
_wrRequests :: Seq (WidgetRequest s),
|
||||
|
||||
@ -140,11 +140,11 @@ runApp window widgetRoot config = do
|
||||
let initAction = handleWidgetInit wenv pathReadyRoot
|
||||
|
||||
handleResourcesInit
|
||||
(newWenv, _, initializedRoot) <- if isJust (config ^. L.stateFileMain)
|
||||
(newWenv, initializedRoot, _, _) <- if isJust (config ^. L.stateFileMain)
|
||||
then catchAll restoreAction (\e -> liftIO (print e) >> initAction)
|
||||
else initAction
|
||||
|
||||
(_, _, resizedRoot) <- resizeWindow window newWenv initializedRoot
|
||||
(_, resizedRoot, _, _) <- resizeWindow window newWenv initializedRoot
|
||||
|
||||
let loopArgs = MainLoopArgs {
|
||||
_mlOS = os,
|
||||
@ -219,7 +219,7 @@ mainLoop window renderer config loopArgs = do
|
||||
let baseReqs
|
||||
| quit = Seq.fromList exitMsgs
|
||||
| otherwise = Seq.Empty
|
||||
let baseStep = (wenv, Seq.empty, _mlWidgetRoot)
|
||||
let baseStep = (wenv, _mlWidgetRoot, Seq.empty, Seq.empty)
|
||||
|
||||
-- when newSecond $
|
||||
-- liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount
|
||||
@ -230,13 +230,13 @@ mainLoop window renderer config loopArgs = do
|
||||
when windowExposed $
|
||||
mainBtnPress .= Nothing
|
||||
|
||||
(rqWenv, _, rqRoot) <- handleRequests baseReqs baseStep
|
||||
(wtWenv, _, wtRoot) <- handleWidgetTasks rqWenv rqRoot
|
||||
(seWenv, _, seRoot) <- handleSystemEvents wtWenv baseSystemEvents wtRoot
|
||||
(rqWenv, rqRoot, _, _) <- handleRequests baseReqs baseStep
|
||||
(wtWenv, wtRoot, _, _) <- handleWidgetTasks rqWenv rqRoot
|
||||
(seWenv, seRoot, _, _) <- handleSystemEvents wtWenv baseSystemEvents wtRoot
|
||||
|
||||
(newWenv, _, newRoot) <- if windowResized
|
||||
(newWenv, newRoot, _, _) <- if windowResized
|
||||
then resizeWindow window seWenv seRoot
|
||||
else return (seWenv, Seq.empty, seRoot)
|
||||
else return (seWenv, seRoot, Seq.empty, Seq.empty)
|
||||
|
||||
endTicks <- fmap fromIntegral SDL.ticks
|
||||
|
||||
|
||||
@ -43,7 +43,8 @@ import Monomer.Main.Util
|
||||
|
||||
import qualified Monomer.Lens as L
|
||||
|
||||
type HandlerStep s e = (WidgetEnv s e, Seq e, WidgetNode s e)
|
||||
type HandlerStep s e
|
||||
= (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s), Seq e)
|
||||
|
||||
getTargetPath
|
||||
:: WidgetEnv s e
|
||||
@ -86,8 +87,8 @@ handleSystemEvents
|
||||
-> m (HandlerStep s e)
|
||||
handleSystemEvents wenv baseEvents widgetRoot = nextStep where
|
||||
mainBtn = wenv ^. L.mainButton
|
||||
reduceBaseEvt currStep evt = do
|
||||
let (currWenv, currEvents, currRoot) = currStep
|
||||
reduceEvt currStep evt = do
|
||||
let (currWenv, currRoot, currReqs, currEvents) = currStep
|
||||
systemEvents <- addRelatedEvents currWenv mainBtn currRoot evt
|
||||
mainBtnPress <- use L.mainBtnPress
|
||||
inputStatus <- use L.inputStatus
|
||||
@ -96,16 +97,16 @@ handleSystemEvents wenv baseEvents widgetRoot = nextStep where
|
||||
& L.mainBtnPress .~ mainBtnPress
|
||||
& L.inputStatus .~ inputStatus
|
||||
|
||||
foldM reduceSysEvt (newWenv, currEvents, currRoot) systemEvents
|
||||
reduceSysEvt (currWenv, currEvents, currRoot) (evt, evtTarget) = do
|
||||
foldM reduceSysEvt (newWenv, currRoot, currReqs, currEvents) systemEvents
|
||||
reduceSysEvt (currWenv, currRoot, currReqs, currEvents) (evt, evtTarget) = do
|
||||
focused <- use L.focusedPath
|
||||
let target = fromMaybe focused evtTarget
|
||||
let trgt = fromMaybe focused evtTarget
|
||||
|
||||
(wenv2, evts2, wroot2) <- handleSystemEvent currWenv evt target currRoot
|
||||
(wenv2, root2, reqs2, evts2) <- handleSystemEvent currWenv evt trgt currRoot
|
||||
|
||||
return (wenv2, currEvents <> evts2, wroot2)
|
||||
processedEvents = preProcessEvents baseEvents
|
||||
nextStep = foldM reduceBaseEvt (wenv, Seq.empty, widgetRoot) processedEvents
|
||||
return (wenv2, root2, currReqs <> reqs2, currEvents <> evts2)
|
||||
newEvents = preProcessEvents baseEvents
|
||||
nextStep = foldM reduceEvt (wenv, widgetRoot, Seq.empty, Seq.empty) newEvents
|
||||
|
||||
handleSystemEvent
|
||||
:: (MonomerM s m)
|
||||
@ -121,7 +122,7 @@ handleSystemEvent wenv event currentTarget widgetRoot = do
|
||||
let pressed = fmap fst mainStart
|
||||
|
||||
case getTargetPath wenv pressed overlay currentTarget event widgetRoot of
|
||||
Nothing -> return (wenv, Seq.empty, widgetRoot)
|
||||
Nothing -> return (wenv, widgetRoot, Seq.empty, Seq.empty)
|
||||
Just target -> do
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let emptyResult = WidgetResult widgetRoot Seq.empty Seq.empty
|
||||
@ -189,7 +190,7 @@ handleWidgetResult wenv resizeWidgets result = do
|
||||
let resizeReq = isResizeResult (Just result)
|
||||
|
||||
resizePending <- use L.resizePending
|
||||
step <- handleRequests reqs (wenv, events, evtRoot)
|
||||
step <- handleRequests reqs (wenv, evtRoot, reqs, events)
|
||||
|
||||
if resizeWidgets && (resizeReq || resizePending)
|
||||
then handleResizeWidgets step
|
||||
@ -236,9 +237,11 @@ handleResizeWidgets previousStep = do
|
||||
|
||||
liftIO . putStrLn $ "Resizing widgets"
|
||||
|
||||
let (wenv, events, widgetRoot) = previousStep
|
||||
let (wenv, widgetRoot, requests, events) = previousStep
|
||||
let reqsNoResize = Seq.filter (not . isResizeWidgets) requests
|
||||
let tmpResult = resizeRoot wenv windowSize widgetRoot
|
||||
let newResult = tmpResult
|
||||
& L.requests .~ reqsNoResize <> tmpResult ^. L.requests
|
||||
& L.events .~ events <> tmpResult ^. L.events
|
||||
|
||||
L.renderRequested .= True
|
||||
@ -252,10 +255,10 @@ handleMoveFocus
|
||||
-> FocusDirection
|
||||
-> HandlerStep s e
|
||||
-> m (HandlerStep s e)
|
||||
handleMoveFocus startFrom direction (wenv, events, root) = do
|
||||
handleMoveFocus startFrom direction (wenv, root, reqs, evts) = do
|
||||
oldFocus <- use L.focusedPath
|
||||
let wenv0 = wenv { _weFocusedPath = emptyPath }
|
||||
(wenv1, events1, root1) <- handleSystemEvent wenv0 Blur oldFocus root
|
||||
(wenv1, root1, reqs1, evts1) <- handleSystemEvent wenv0 Blur oldFocus root
|
||||
currFocus <- use L.focusedPath
|
||||
currOverlay <- use L.overlayPath
|
||||
|
||||
@ -267,41 +270,41 @@ handleMoveFocus startFrom direction (wenv, events, root) = do
|
||||
|
||||
L.focusedPath .= newFocus
|
||||
L.renderRequested .= True
|
||||
(wenv2, events2, root2) <- handleSystemEvent tempWenv Focus newFocus root1
|
||||
(wenv2, root2, reqs2, evts2) <- handleSystemEvent tempWenv Focus newFocus root1
|
||||
|
||||
return (wenv2, events <> events1 <> events2, root2)
|
||||
return (wenv2, root2, reqs <> reqs1 <> reqs2, evts <> evts1 <> evts2)
|
||||
else
|
||||
return (wenv1, events1, root1)
|
||||
return (wenv1, root1, reqs1, evts1)
|
||||
|
||||
handleSetFocus
|
||||
:: (MonomerM s m) => Path -> HandlerStep s e -> m (HandlerStep s e)
|
||||
handleSetFocus newFocus (wenv, events, root) = do
|
||||
handleSetFocus newFocus (wenv, root, reqs, evts) = do
|
||||
let wenv0 = wenv { _weFocusedPath = newFocus }
|
||||
|
||||
oldFocus <- use L.focusedPath
|
||||
|
||||
if oldFocus /= newFocus
|
||||
then do
|
||||
(wenv1, events1, root1) <- handleSystemEvent wenv0 Blur oldFocus root
|
||||
(wenv1, root1, reqs1, evts1) <- handleSystemEvent wenv0 Blur oldFocus root
|
||||
|
||||
L.focusedPath .= newFocus
|
||||
L.renderRequested .= True
|
||||
(wenv2, events2, root2) <- handleSystemEvent wenv1 Focus newFocus root1
|
||||
(wenv2, root2, reqs2, evts2) <- handleSystemEvent wenv1 Focus newFocus root1
|
||||
|
||||
return (wenv2, events <> events1 <> events2, root2)
|
||||
return (wenv2, root2, reqs <> reqs1 <> reqs2, evts <> evts1 <> evts2)
|
||||
else
|
||||
return (wenv, events, root)
|
||||
return (wenv, root, reqs, evts)
|
||||
|
||||
handleGetClipboard
|
||||
:: (MonomerM s m) => Path -> HandlerStep s e -> m (HandlerStep s e)
|
||||
handleGetClipboard path (wenv, evts, root) = do
|
||||
handleGetClipboard path (wenv, root, reqs, evts) = do
|
||||
hasText <- SDL.hasClipboardText
|
||||
contents <- if hasText
|
||||
contents <- fmap Clipboard $ if hasText
|
||||
then fmap ClipboardText SDL.getClipboardText
|
||||
else return ClipboardEmpty
|
||||
|
||||
(wenv2, evts2, root2) <- handleSystemEvent wenv (Clipboard contents) path root
|
||||
return (wenv2, evts <> evts2, root2)
|
||||
(wenv2, root2, reqs2, evts2) <- handleSystemEvent wenv contents path root
|
||||
return (wenv2, root2, reqs <> reqs2, evts <> evts2)
|
||||
|
||||
handleSetClipboard
|
||||
:: (MonomerM s m) => ClipboardData -> HandlerStep s e -> m (HandlerStep s e)
|
||||
@ -360,7 +363,7 @@ handleRenderEvery path ms repeat previousStep = do
|
||||
L.renderSchedule .= addSchedule schedule
|
||||
return previousStep
|
||||
where
|
||||
(wenv, _, _) = previousStep
|
||||
(wenv, _, _, _) = previousStep
|
||||
newValue = RenderSchedule {
|
||||
_rsPath = path,
|
||||
_rsStart = _weTimestamp wenv,
|
||||
@ -398,9 +401,9 @@ handleUpdateWindow windowRequest previousStep = do
|
||||
|
||||
handleUpdateModel
|
||||
:: (MonomerM s m) => (s -> s) -> HandlerStep s e -> m (HandlerStep s e)
|
||||
handleUpdateModel fn (wenv, evts, root) = do
|
||||
handleUpdateModel fn (wenv, root, reqs, evts) = do
|
||||
L.mainModel .= _weModel wenv2
|
||||
return (wenv2, evts, root)
|
||||
return (wenv2, root, reqs, evts)
|
||||
where
|
||||
wenv2 = wenv & L.model %~ fn
|
||||
|
||||
@ -416,15 +419,15 @@ handleSendMessage
|
||||
-> msg
|
||||
-> HandlerStep s e
|
||||
-> m (HandlerStep s e)
|
||||
handleSendMessage path message (wenv, events, widgetRoot) = do
|
||||
let emptyResult = WidgetResult widgetRoot Seq.empty Seq.empty
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let msgResult = widgetHandleMessage widget wenv path message widgetRoot
|
||||
handleSendMessage path message (wenv, root, reqs, evts) = do
|
||||
let emptyResult = WidgetResult root Seq.empty Seq.empty
|
||||
let widget = root ^. L.widget
|
||||
let msgResult = widgetHandleMessage widget wenv path message root
|
||||
let result = fromMaybe emptyResult msgResult
|
||||
|
||||
(newWenv, newEvents, newWidgetRoot) <- handleWidgetResult wenv True result
|
||||
(newWenv, newRoot, newReqs, newEvts) <- handleWidgetResult wenv True result
|
||||
|
||||
return (newWenv, events <> newEvents, newWidgetRoot)
|
||||
return (newWenv, newRoot, reqs <> newReqs, evts <> newEvts)
|
||||
|
||||
handleRunTask
|
||||
:: forall s e m i . (MonomerM s m, Typeable i)
|
||||
|
||||
@ -11,7 +11,6 @@ import Control.Monad.IO.Class
|
||||
import Control.Monad.STM (atomically)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Maybe
|
||||
import Data.Sequence ((><))
|
||||
import Data.Typeable
|
||||
|
||||
import qualified Data.Sequence as Seq
|
||||
@ -43,10 +42,10 @@ processTasks
|
||||
-> t WidgetTask
|
||||
-> m (HandlerStep s e)
|
||||
processTasks wenv widgetRoot tasks = nextStep where
|
||||
reducer (wWctx, wEvts, wRoot) task = do
|
||||
(wWctx2, wEvts2, wRoot2) <- processTask wWctx wRoot task
|
||||
return (wWctx2, wEvts >< wEvts2, wRoot2)
|
||||
nextStep = foldM reducer (wenv, Seq.empty, widgetRoot) tasks
|
||||
reducer (wWctx, wRoot, wReqs, wEvts) task = do
|
||||
(wWctx2, wRoot2, wReqs2, wEvts2) <- processTask wWctx wRoot task
|
||||
return (wWctx2, wRoot2, wReqs <> wReqs2, wEvts <> wEvts2)
|
||||
nextStep = foldM reducer (wenv, widgetRoot, Seq.empty, Seq.empty) tasks
|
||||
|
||||
processTask
|
||||
:: (MonomerM s m)
|
||||
@ -59,13 +58,13 @@ processTask wenv widgetRoot (WidgetTask widgetId task) = do
|
||||
|
||||
case taskStatus of
|
||||
Just taskRes -> processTaskResult wenv widgetRoot widgetId taskRes
|
||||
Nothing -> return (wenv, Seq.empty, widgetRoot)
|
||||
Nothing -> return (wenv, widgetRoot, Seq.empty, Seq.empty)
|
||||
processTask model widgetRoot (WidgetProducer widgetId channel task) = do
|
||||
channelStatus <- liftIO . atomically $ tryReadTChan channel
|
||||
|
||||
case channelStatus of
|
||||
Just taskMsg -> processTaskEvent model widgetRoot widgetId taskMsg
|
||||
Nothing -> return (model, Seq.empty, widgetRoot)
|
||||
Nothing -> return (model, widgetRoot, Seq.empty, Seq.empty)
|
||||
|
||||
processTaskResult
|
||||
:: (MonomerM s m, Typeable a)
|
||||
@ -76,7 +75,7 @@ processTaskResult
|
||||
-> m (HandlerStep s e)
|
||||
processTaskResult wenv widgetRoot _ (Left ex) = do
|
||||
liftIO . putStrLn $ "Error processing Widget task result: " ++ show ex
|
||||
return (wenv, Seq.empty, widgetRoot)
|
||||
return (wenv, widgetRoot, Seq.empty, Seq.empty)
|
||||
processTaskResult wenv widgetRoot widgetId (Right taskResult)
|
||||
= processTaskEvent wenv widgetRoot widgetId taskResult
|
||||
|
||||
|
||||
@ -37,7 +37,7 @@ import Data.Foldable (fold, foldl')
|
||||
import Data.Maybe
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Sequence (Seq(..), (<|), (|>), (><))
|
||||
import Data.Sequence (Seq(..), (<|), (|>))
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Sequence as Seq
|
||||
@ -642,12 +642,12 @@ 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 newWidget requests userEvents
|
||||
| otherwise = Just $ WidgetResult newWidget requests events
|
||||
where
|
||||
pWidget = _wrNode pResponse
|
||||
cWidget = _wrNode cResponse
|
||||
requests = _wrRequests pResponse >< _wrRequests cResponse
|
||||
userEvents = _wrEvents pResponse >< _wrEvents cResponse
|
||||
requests = _wrRequests pResponse <> _wrRequests cResponse
|
||||
events = _wrEvents pResponse <> _wrEvents cResponse
|
||||
newWidget = replaceChild pWidget cWidget idx
|
||||
newChildResponse = cResponse {
|
||||
_wrNode = replaceChild original (_wrNode cResponse) idx
|
||||
|
||||
@ -22,7 +22,7 @@ import Control.Lens ((&), (+~))
|
||||
import Data.Default
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe
|
||||
import Data.Sequence (Seq(..), (><), (<|), (|>))
|
||||
import Data.Sequence (Seq(..), (<|), (|>))
|
||||
import Data.Text (Text)
|
||||
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
@ -165,16 +165,7 @@ nodeHandleEventModel
|
||||
-> WidgetNode s e
|
||||
-> s
|
||||
nodeHandleEventModel wenv evts node = _weModel wenv2 where
|
||||
(wenv2, _, _) = fst $ nodeHandleEvents wenv evts node
|
||||
|
||||
nodeHandleEventEvts
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> [SystemEvent]
|
||||
-> WidgetNode s e
|
||||
-> Seq e
|
||||
nodeHandleEventEvts wenv evts node = events where
|
||||
(_, events, _) = fst $ nodeHandleEvents wenv evts node
|
||||
(wenv2, _, _, _) = fst $ nodeHandleEvents wenv evts node
|
||||
|
||||
nodeHandleEventRoot
|
||||
:: (Eq s)
|
||||
@ -183,7 +174,25 @@ nodeHandleEventRoot
|
||||
-> WidgetNode s e
|
||||
-> WidgetNode s e
|
||||
nodeHandleEventRoot wenv evts node = newRoot where
|
||||
(_, _, newRoot) = fst $ nodeHandleEvents wenv evts node
|
||||
(_, newRoot, _, _) = fst $ nodeHandleEvents wenv evts node
|
||||
|
||||
nodeHandleEventReqs
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> [SystemEvent]
|
||||
-> WidgetNode s e
|
||||
-> Seq (WidgetRequest s)
|
||||
nodeHandleEventReqs wenv evts node = reqs where
|
||||
(_, _, reqs, _) = fst $ nodeHandleEvents wenv evts node
|
||||
|
||||
nodeHandleEventEvts
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> [SystemEvent]
|
||||
-> WidgetNode s e
|
||||
-> Seq e
|
||||
nodeHandleEventEvts wenv evts node = events where
|
||||
(_, _, _, events) = fst $ nodeHandleEvents wenv evts node
|
||||
|
||||
nodeHandleEvents
|
||||
:: (Eq s)
|
||||
@ -205,7 +214,7 @@ nodeHandleEvents wenv evts node = unsafePerformIO $ do
|
||||
|
||||
flip runStateT monomerContext $ do
|
||||
handleResourcesInit
|
||||
(wenv2, _, newNode) <- handleWidgetInit wenv pathReadyRoot
|
||||
(wenv2, newNode, _, _) <- handleWidgetInit wenv pathReadyRoot
|
||||
let resizedNode = nodeResize wenv2 vp newNode
|
||||
|
||||
handleSystemEvents wenv2 evts resizedNode
|
||||
@ -217,7 +226,7 @@ nodeHandleEventModelNoInit
|
||||
-> WidgetNode s e
|
||||
-> s
|
||||
nodeHandleEventModelNoInit wenv evts node = _weModel wenv2 where
|
||||
(wenv2, _, _) = fst $ nodeHandleEventsNoInit wenv evts node
|
||||
(wenv2, _, _, _) = fst $ nodeHandleEventsNoInit wenv evts node
|
||||
|
||||
nodeHandleEventRootNoInit
|
||||
:: (Eq s)
|
||||
@ -226,7 +235,16 @@ nodeHandleEventRootNoInit
|
||||
-> WidgetNode s e
|
||||
-> WidgetNode s e
|
||||
nodeHandleEventRootNoInit wenv evts node = newRoot where
|
||||
(_, _, newRoot) = fst $ nodeHandleEventsNoInit wenv evts node
|
||||
(_, newRoot, _, _) = fst $ nodeHandleEventsNoInit wenv evts node
|
||||
|
||||
nodeHandleEventReqsNoInit
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> [SystemEvent]
|
||||
-> WidgetNode s e
|
||||
-> Seq (WidgetRequest s)
|
||||
nodeHandleEventReqsNoInit wenv evts node = newReqs where
|
||||
(_, _, newReqs, _) = fst $ nodeHandleEventsNoInit wenv evts node
|
||||
|
||||
nodeHandleEventsNoInit
|
||||
:: (Eq s)
|
||||
|
||||
@ -201,10 +201,10 @@ handleEventLocalKey = describe "handleEventLocalKey" $
|
||||
cmpNode1 = composite "main" id buildUI1 handleEvent
|
||||
cmpNode2 = composite_ "main" id buildUI2 handleEvent [mergeRequired (\_ _ -> True)]
|
||||
evts1 = [evtK keyTab, evtT "aacc", moveCharL, moveCharL]
|
||||
((wenv1, _, root1), ctx1) = nodeHandleEvents wenv evts1 cmpNode1
|
||||
((wenv1, root1, _, _), ctx1) = nodeHandleEvents wenv evts1 cmpNode1
|
||||
cntNodeM = nodeMerge wenv1 root1 cmpNode2
|
||||
evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
|
||||
((wenv2, _, root2), ctx2) = nodeHandleEventsNoInit wenv1 evts2 cntNodeM
|
||||
((wenv2, root2, _, _), ctx2) = nodeHandleEventsNoInit wenv1 evts2 cntNodeM
|
||||
newInstRoot = widgetSave (root2 ^. L.widget) wenv1 root2
|
||||
|
||||
handleEventGlobalKey :: Spec
|
||||
@ -247,10 +247,10 @@ handleEventGlobalKey = describe "handleEventGlobalKey" $
|
||||
cmpNode1 = composite "main" id buildUI1 handleEvent
|
||||
cmpNode2 = composite_ "main" id buildUI2 handleEvent [mergeRequired (\_ _ -> True)]
|
||||
evts1 = [evtT "aacc", moveCharL, moveCharL]
|
||||
((wenv1, _, root1), ctx1) = nodeHandleEvents wenv evts1 cmpNode1
|
||||
((wenv1, root1, _, _), ctx1) = nodeHandleEvents wenv evts1 cmpNode1
|
||||
cntNodeM = nodeMerge wenv1 root1 cmpNode2
|
||||
evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
|
||||
((wenv2, _, root2), ctx2) = nodeHandleEventsNoInit wenv1 evts2 cntNodeM
|
||||
((wenv2, root2, _, _), ctx2) = nodeHandleEventsNoInit wenv1 evts2 cntNodeM
|
||||
newInstRoot = widgetSave (root2 ^. L.widget) wenv1 root2
|
||||
|
||||
handleMessage :: Spec
|
||||
|
||||
@ -69,7 +69,7 @@ handleEventNormal = describe "handleEventNormal" $
|
||||
]
|
||||
evts1 = [evtT "aacc", moveCharL, moveCharL]
|
||||
model1 = nodeHandleEventModel wenv evts1 cntNode1
|
||||
(wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cntNode1
|
||||
(wenv1, oldRoot1, _, _) = fst $ nodeHandleEvents wenv evts1 cntNode1
|
||||
cntNodeM = nodeMerge wenv1 oldRoot1 cntNode2
|
||||
evts2 = [evtK keyTab, evtT "bb"]
|
||||
modelM = nodeHandleEventModelNoInit wenv1 evts2 cntNodeM
|
||||
@ -99,7 +99,7 @@ handleEventNoKey = describe "handleEventNoKey" $
|
||||
]
|
||||
evts1 = [evtT "aacc", moveCharL, moveCharL]
|
||||
model1 = nodeHandleEventModel wenv evts1 cntNode1
|
||||
(wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cntNode1
|
||||
(wenv1, oldRoot1, _, _) = fst $ nodeHandleEvents wenv evts1 cntNode1
|
||||
cntNodeM = nodeMerge wenv1 oldRoot1 cntNode2
|
||||
evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
|
||||
modelM = nodeHandleEventModelNoInit wenv1 evts2 cntNodeM
|
||||
@ -130,7 +130,7 @@ handleEventLocalKey = describe "handleEventLocalKey" $
|
||||
]
|
||||
evts1 = [evtT "aacc", moveCharL, moveCharL]
|
||||
model1 = nodeHandleEventModel wenv evts1 cntNode1
|
||||
(wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cntNode1
|
||||
(wenv1, oldRoot1, _, _) = fst $ nodeHandleEvents wenv evts1 cntNode1
|
||||
cntNodeM = nodeMerge wenv1 oldRoot1 cntNode2
|
||||
evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
|
||||
modelM = nodeHandleEventModelNoInit wenv1 evts2 cntNodeM
|
||||
|
||||
@ -155,7 +155,7 @@ handleEventRestored = describe "handleEventRestored" $ do
|
||||
oldNode = nodeHandleEventRoot wenv startEvts node1
|
||||
inst1 = widgetSave (oldNode ^. L.widget) wenv oldNode
|
||||
inst2 = deserialise (serialise inst1)
|
||||
((wenv2, evts2, node2), ctx) = nodeHandleRestore wenv inst2 node1
|
||||
((wenv2, node2, reqs2, evts2), ctx) = nodeHandleRestore wenv inst2 node1
|
||||
clickModel p = nodeHandleEventModelNoInit wenv2 [Click p LeftBtn] node2
|
||||
model evts = nodeHandleEventModelNoInit wenv2 evts node2
|
||||
|
||||
|
||||
@ -131,7 +131,7 @@ handleRestoredEvents wenv node1 = (model2, oldInfo, rstInfo) where
|
||||
newNode = node1 `style` [textColor red]
|
||||
inst1 = widgetSave (oldNode ^. L.widget) wenv oldNode
|
||||
inst2 = deserialise (serialise inst1)
|
||||
((wenv2, evts2, node2), ctx) = nodeHandleRestore wenv inst2 newNode
|
||||
((wenv2, node2, reqs2, evts2), ctx) = nodeHandleRestore wenv inst2 newNode
|
||||
model2 = nodeHandleEventModelNoInit wenv2 [evtK keyTab, evtT " restore"] node2
|
||||
oldStyle = setStyleValue (oldNode ^. L.info . L.style) setFontColorL (?~) red
|
||||
oldInfo = oldNode ^. L.info
|
||||
|
||||
@ -3,8 +3,9 @@
|
||||
|
||||
module Monomer.Widgets.TooltipSpec (spec) where
|
||||
|
||||
import Control.Lens ((&), (^.), (.~))
|
||||
import Control.Lens ((&), (^.), (.~), (%~))
|
||||
import Data.Default
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import Test.Hspec
|
||||
|
||||
@ -26,35 +27,69 @@ import qualified Monomer.Lens as L
|
||||
spec :: Spec
|
||||
spec = describe "Tooltip" $ do
|
||||
handleEvent
|
||||
handleEventFollow
|
||||
getSizeReq
|
||||
|
||||
handleEvent :: Spec
|
||||
handleEvent = describe "handleEvent" $ do
|
||||
it "should not generate a render schedule" $ do
|
||||
ctx [] ^. L.renderRequested `shouldBe` True
|
||||
ctx [] ^. L.renderSchedule `shouldBe` M.empty
|
||||
reqs [] `shouldBe` Seq.empty
|
||||
|
||||
it "should generate a render schedule after moving" $ do
|
||||
let evt = Move (Point 10 10)
|
||||
let path = Seq.fromList [0, 0]
|
||||
let schedule = RenderSchedule path 0 1000 (Just 1)
|
||||
ctx [evt] ^. L.renderRequested `shouldBe` True
|
||||
ctx [evt] ^. L.renderSchedule `shouldBe` M.fromList [(path, schedule)]
|
||||
let path = Seq.fromList [0]
|
||||
let renderEveryReq = RenderEvery path 1000 (Just 1)
|
||||
reqs [evt] `shouldBe` Seq.fromList [renderEveryReq]
|
||||
|
||||
it "should ony generate a render schedule even after moving, since delay has not passed" $ do
|
||||
let evt1 = Move (Point 10 10)
|
||||
let evt2 = Move (Point 50 50)
|
||||
let path = Seq.fromList [0]
|
||||
let renderEveryReq = RenderEvery path 1000 (Just 1)
|
||||
reqs [evt1, evt2] `shouldBe` Seq.fromList [renderEveryReq]
|
||||
|
||||
where
|
||||
wenv = mockWenvEvtUnit ()
|
||||
ttNode = tooltip "" (label "Test")
|
||||
reqs es = getReqs wenv ttNode es
|
||||
|
||||
handleEventFollow :: Spec
|
||||
handleEventFollow = describe "handleEventFollow" $ do
|
||||
it "should not generate a render schedule" $ do
|
||||
reqs [] `shouldBe` Seq.empty
|
||||
|
||||
it "should generate a render schedule after moving" $ do
|
||||
let evt = Move (Point 10 10)
|
||||
let path = Seq.fromList [0]
|
||||
let renderEveryReq = RenderEvery path 500 (Just 1)
|
||||
reqs [evt] `shouldBe` Seq.fromList [renderEveryReq]
|
||||
|
||||
it "should generate a render schedule even after moving, and RenderOnce after" $ do
|
||||
let evt1 = Move (Point 10 10)
|
||||
let evt2 = Move (Point 50 50)
|
||||
let path = Seq.fromList [0, 0]
|
||||
let schedule = RenderSchedule path 0 1000 (Just 1)
|
||||
ctx [evt1, evt2] ^. L.renderRequested `shouldBe` True
|
||||
ctx [evt1, evt2] ^. L.renderSchedule `shouldBe` M.fromList [(path, schedule)]
|
||||
let path = Seq.fromList [0]
|
||||
let renderEveryReq = RenderEvery path 500 (Just 1)
|
||||
reqs [evt1, evt2] `shouldBe` Seq.fromList [renderEveryReq, RenderOnce]
|
||||
|
||||
where
|
||||
wenv = mockWenvEvtUnit ()
|
||||
ttNode = vstack [
|
||||
tooltip "" (label "Test")
|
||||
]
|
||||
ctx es = nodeHandleEventCtx wenv es ttNode
|
||||
ttNode = tooltip_ "" (label "Test") [tooltipDelay 500, tooltipFollow]
|
||||
reqs es = getReqs wenv ttNode es
|
||||
|
||||
getReqs
|
||||
:: Eq s
|
||||
=> WidgetEnv s e
|
||||
-> WidgetNode s e
|
||||
-> [SystemEvent]
|
||||
-> Seq (WidgetRequest s)
|
||||
getReqs wenv node [] = Seq.empty
|
||||
getReqs wenv node (e:es) = tmpReqs <> newReqs where
|
||||
-- Each component generates a RenderOnce request when Enter event is received
|
||||
tmpNode = nodeHandleEventRoot wenv [e] node
|
||||
tmpReqs = Seq.drop 2 $ nodeHandleEventReqs wenv [e] node
|
||||
newWenv = wenv & L.timestamp %~ (+1000)
|
||||
newNode = nodeHandleEventRootNoInit newWenv es tmpNode
|
||||
newReqs = Seq.drop 2 $ nodeHandleEventReqsNoInit newWenv es tmpNode
|
||||
|
||||
getSizeReq :: Spec
|
||||
getSizeReq = describe "getSizeReq" $ do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user