mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-10-26 19:49:50 +03:00
Refactor event preprocessing logic (move from Core to Handlers). Add text selection unit tests
This commit is contained in:
parent
e645563f9d
commit
58cd92a40b
@ -51,6 +51,7 @@
|
||||
# - ignore: {name: Use let}
|
||||
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
|
||||
|
||||
- ignore: {name: Eta reduce}
|
||||
- ignore: {name: Reduce duplication}
|
||||
|
||||
# Define some custom infix operators
|
||||
|
@ -159,35 +159,32 @@ mainLoop
|
||||
-> MainLoopArgs s e ep
|
||||
-> m ()
|
||||
mainLoop window renderer config loopArgs = do
|
||||
windowSize <- use L.windowSize
|
||||
useHiDPI <- use hdpi
|
||||
devicePixelRate <- use dpr
|
||||
startTicks <- fmap fromIntegral SDL.ticks
|
||||
events <- SDL.pollEvents
|
||||
mousePos <- getCurrentMousePos
|
||||
currentModel <- use mainModel
|
||||
currentCursor <- use currentCursor
|
||||
focused <- use focusedPath
|
||||
overlay <- use overlayPath
|
||||
mainPress <- use mainBtnPress
|
||||
|
||||
windowSize <- use L.windowSize
|
||||
useHiDPI <- use L.hdpi
|
||||
devicePixelRate <- use L.dpr
|
||||
currentModel <- use L.mainModel
|
||||
currentCursor <- use L.currentCursor
|
||||
focused <- use L.focusedPath
|
||||
overlay <- use L.overlayPath
|
||||
mainPress <- use L.mainBtnPress
|
||||
inputStatus <- use L.inputStatus
|
||||
|
||||
let MainLoopArgs{..} = loopArgs
|
||||
let !ts = startTicks - _mlFrameStartTs
|
||||
let eventsPayload = fmap SDL.eventPayload events
|
||||
let quit = SDL.QuitEvent `elem` eventsPayload
|
||||
|
||||
let windowResized = isWindowResized eventsPayload
|
||||
let windowExposed = isWindowExposed eventsPayload
|
||||
let mouseEntered = isMouseEntered eventsPayload
|
||||
let mousePixelRate = if not useHiDPI then devicePixelRate else 1
|
||||
let baseSystemEvents = convertEvents mousePixelRate mousePos eventsPayload
|
||||
|
||||
let newSecond = _mlFrameAccumTs > 1000
|
||||
|
||||
inputStatus <- updateInputStatus baseSystemEvents
|
||||
|
||||
when quit $ exitApplication .= True
|
||||
|
||||
let mainBtn = fromMaybe LeftBtn (_apcMainButton config)
|
||||
let isMainBtnPressed = isButtonPressed inputStatus mainBtn
|
||||
let wenv = WidgetEnv {
|
||||
_weOS = _mlOS,
|
||||
_weRenderer = renderer,
|
||||
@ -204,26 +201,28 @@ mainLoop window renderer config loopArgs = do
|
||||
_weTimestamp = startTicks,
|
||||
_weInTopLayer = const True
|
||||
}
|
||||
|
||||
when newSecond $
|
||||
liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount
|
||||
|
||||
sysEvents <- preProcessEvents wenv mainBtn _mlWidgetRoot baseSystemEvents
|
||||
|
||||
-- Exit handler
|
||||
let quit = SDL.QuitEvent `elem` eventsPayload
|
||||
let exitMsg = SendMessage (Seq.fromList [0]) _mlExitEvent
|
||||
let baseReqs = Seq.fromList [ exitMsg | quit ]
|
||||
let baseStep = (wenv, Seq.empty, _mlWidgetRoot)
|
||||
|
||||
when (windowExposed && isMainBtnPressed) $
|
||||
when newSecond $
|
||||
liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount
|
||||
|
||||
when quit $
|
||||
exitApplication .= True
|
||||
|
||||
when windowExposed $
|
||||
mainBtnPress .= Nothing
|
||||
|
||||
(rqWenv, _, rqRoot) <- handleRequests baseReqs baseStep
|
||||
(wtWenv, _, wtRoot) <- handleWidgetTasks rqWenv rqRoot
|
||||
(seWenv, _, seRoot) <- handleSystemEvents wtWenv sysEvents wtRoot
|
||||
(seWenv, _, seRoot) <- handleSystemEvents wtWenv baseSystemEvents wtRoot
|
||||
|
||||
newRoot <- if windowResized then resizeWindow window seWenv seRoot
|
||||
else return seRoot
|
||||
newRoot <- if windowResized
|
||||
then resizeWindow window seWenv seRoot
|
||||
else return seRoot
|
||||
|
||||
endTicks <- fmap fromIntegral SDL.ticks
|
||||
|
||||
@ -300,81 +299,6 @@ renderWidgets !window renderer wenv widgetRoot = do
|
||||
liftIO $ endFrame renderer
|
||||
SDL.glSwapWindow window
|
||||
|
||||
-- Pre process events (change focus, add Enter/Leave events, etc)
|
||||
preProcessEvents
|
||||
:: (MonomerM s m)
|
||||
=> WidgetEnv s e
|
||||
-> Button
|
||||
-> WidgetNode s e
|
||||
-> [SystemEvent]
|
||||
-> m [SystemEvent]
|
||||
preProcessEvents wenv mainBtn widgets events =
|
||||
concatMapM (preProcessEvent wenv mainBtn widgets) events
|
||||
|
||||
preProcessEvent
|
||||
:: (MonomerM s m)
|
||||
=> WidgetEnv s e
|
||||
-> Button
|
||||
-> WidgetNode s e
|
||||
-> SystemEvent
|
||||
-> m [SystemEvent]
|
||||
preProcessEvent wenv mainBtn widgetRoot evt = case evt of
|
||||
Move point -> do
|
||||
overlay <- use L.overlayPath
|
||||
hover <- use hoveredPath
|
||||
let startPath = fromMaybe rootPath overlay
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let curr = widgetFindByPoint widget wenv startPath point widgetRoot
|
||||
let hoverChanged = curr /= hover
|
||||
let enter = [Enter (fromJust curr) point | isJust curr && hoverChanged]
|
||||
let leave = [Leave (fromJust hover) point | isJust hover && hoverChanged]
|
||||
|
||||
when hoverChanged $
|
||||
hoveredPath .= curr
|
||||
|
||||
return $ leave ++ enter ++ [evt]
|
||||
ButtonAction point btn PressedBtn -> do
|
||||
overlay <- use L.overlayPath
|
||||
let startPath = fromMaybe rootPath overlay
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let curr = widgetFindByPoint widget wenv startPath point widgetRoot
|
||||
|
||||
when (btn == mainBtn) $
|
||||
mainBtnPress .= fmap (, point) curr
|
||||
|
||||
return [evt]
|
||||
ButtonAction point btn ReleasedBtn -> do
|
||||
overlay <- use L.overlayPath
|
||||
mainPress <- use mainBtnPress
|
||||
let pressed = fmap fst mainPress
|
||||
let startPath = fromMaybe rootPath overlay
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let curr = widgetFindByPoint widget wenv startPath point widgetRoot
|
||||
let extraEvt = [Click point btn | btn == mainBtn && curr == pressed]
|
||||
|
||||
when (btn == mainBtn) $
|
||||
mainBtnPress .= Nothing
|
||||
|
||||
return $ extraEvt ++ [evt]
|
||||
_ -> return [evt]
|
||||
|
||||
updateInputStatus :: (MonomerM s m) => [SystemEvent] -> m InputStatus
|
||||
updateInputStatus systemEvents = do
|
||||
mapM_ evtToInputStatus systemEvents
|
||||
use inputStatus
|
||||
|
||||
evtToInputStatus :: (MonomerM s m) => SystemEvent -> m ()
|
||||
evtToInputStatus (Move point) = do
|
||||
status <- use inputStatus
|
||||
inputStatus . mousePosPrev .= status ^. mousePos
|
||||
inputStatus . mousePos .= point
|
||||
evtToInputStatus (ButtonAction _ btn btnState) =
|
||||
inputStatus . buttons . at btn ?= btnState
|
||||
evtToInputStatus (KeyAction kMod kCode kStatus) = do
|
||||
inputStatus . keyMod .= kMod
|
||||
inputStatus . keys . at kCode ?= kStatus
|
||||
evtToInputStatus _ = return ()
|
||||
|
||||
isWindowResized :: [SDL.EventPayload] -> Bool
|
||||
isWindowResized eventsPayload = not status where
|
||||
status = null [ e | e@SDL.WindowResizedEvent {} <- eventsPayload ]
|
||||
|
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Monomer.Main.Handlers (
|
||||
HandlerStep,
|
||||
@ -12,11 +13,12 @@ module Monomer.Main.Handlers (
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Async (async)
|
||||
import Control.Lens ((&), (^.), (%~), (.=), at, non, use)
|
||||
import Control.Lens ((&), (^.), (.~), (%~), (.=), (?=), at, non, use)
|
||||
import Control.Monad.STM (atomically)
|
||||
import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan)
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad
|
||||
import Control.Monad.Extra(concatMapM)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe
|
||||
@ -47,13 +49,25 @@ handleSystemEvents
|
||||
-> [SystemEvent]
|
||||
-> WidgetNode s e
|
||||
-> m (HandlerStep s e)
|
||||
handleSystemEvents wenv systemEvents widgetRoot = nextStep where
|
||||
reducer (currWctx, currEvents, currRoot) evt = do
|
||||
focused <- use L.focusedPath
|
||||
handleSystemEvents wenv baseEvents widgetRoot = nextStep where
|
||||
mainBtn = wenv ^. L.mainButton
|
||||
reduceBaseEvt currStep evt = do
|
||||
let (currWenv, currEvents, currRoot) = currStep
|
||||
systemEvents <- preProcessEvent currWenv mainBtn currRoot evt
|
||||
mainBtnPress <- use L.mainBtnPress
|
||||
inputStatus <- use L.inputStatus
|
||||
|
||||
let newWenv = currWenv
|
||||
& L.mainBtnPress .~ mainBtnPress
|
||||
& L.inputStatus .~ inputStatus
|
||||
|
||||
foldM reduceSysEvt (newWenv, currEvents, currRoot) systemEvents
|
||||
reduceSysEvt (currWenv, currEvents, currRoot) evt = do
|
||||
focused <- use L.focusedPath
|
||||
(wenv2, evts2, wroot2) <- handleSystemEvent currWenv evt focused currRoot
|
||||
|
||||
(wenv2, evts2, wroot2) <- handleSystemEvent currWctx evt focused currRoot
|
||||
return (wenv2, currEvents >< evts2, wroot2)
|
||||
nextStep = foldM reducer (wenv, Seq.empty, widgetRoot) systemEvents
|
||||
nextStep = foldM reduceBaseEvt (wenv, Seq.empty, widgetRoot) baseEvents
|
||||
|
||||
handleSystemEvent
|
||||
:: (MonomerM s m)
|
||||
@ -379,6 +393,67 @@ addFocusReq (KeyAction mod code KeyPressed) reqs = newReqs where
|
||||
| otherwise = reqs
|
||||
addFocusReq _ reqs = reqs
|
||||
|
||||
preProcessEvent
|
||||
:: (MonomerM s m)
|
||||
=> WidgetEnv s e
|
||||
-> Button
|
||||
-> WidgetNode s e
|
||||
-> SystemEvent
|
||||
-> m [SystemEvent]
|
||||
preProcessEvent wenv mainBtn widgetRoot evt = case evt of
|
||||
Move point -> do
|
||||
overlay <- use L.overlayPath
|
||||
hover <- use L.hoveredPath
|
||||
let startPath = fromMaybe rootPath overlay
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let curr = widgetFindByPoint widget wenv startPath point widgetRoot
|
||||
let hoverChanged = curr /= hover
|
||||
let enter = [Enter (fromJust curr) point | isJust curr && hoverChanged]
|
||||
let leave = [Leave (fromJust hover) point | isJust hover && hoverChanged]
|
||||
|
||||
when hoverChanged $
|
||||
L.hoveredPath .= curr
|
||||
|
||||
-- Update input status
|
||||
status <- use L.inputStatus
|
||||
L.inputStatus . L.mousePosPrev .= status ^. L.mousePos
|
||||
L.inputStatus . L.mousePos .= point
|
||||
|
||||
return $ leave ++ enter ++ [evt]
|
||||
ButtonAction point btn PressedBtn -> do
|
||||
overlay <- use L.overlayPath
|
||||
let startPath = fromMaybe rootPath overlay
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let curr = widgetFindByPoint widget wenv startPath point widgetRoot
|
||||
|
||||
when (btn == mainBtn) $
|
||||
L.mainBtnPress .= fmap (, point) curr
|
||||
|
||||
L.inputStatus . L.buttons . at btn ?= PressedBtn
|
||||
|
||||
return [evt]
|
||||
ButtonAction point btn ReleasedBtn -> do
|
||||
overlay <- use L.overlayPath
|
||||
mainPress <- use L.mainBtnPress
|
||||
let pressed = fmap fst mainPress
|
||||
let startPath = fromMaybe rootPath overlay
|
||||
let widget = widgetRoot ^. L.widget
|
||||
let curr = widgetFindByPoint widget wenv startPath point widgetRoot
|
||||
let extraEvt = [Click point btn | btn == mainBtn && curr == pressed]
|
||||
|
||||
when (btn == mainBtn) $
|
||||
L.mainBtnPress .= Nothing
|
||||
|
||||
L.inputStatus . L.buttons . at btn ?= ReleasedBtn
|
||||
|
||||
return $ extraEvt ++ [evt]
|
||||
KeyAction mod code status -> do
|
||||
L.inputStatus . L.keyMod .= mod
|
||||
L.inputStatus . L.keys . at code ?= status
|
||||
|
||||
return [evt]
|
||||
_ -> return [evt]
|
||||
|
||||
sendMessage :: TChan e -> e -> IO ()
|
||||
sendMessage channel message = atomically $ writeTChan channel message
|
||||
|
||||
|
1
tasks.md
1
tasks.md
@ -365,6 +365,7 @@ Maybe postponed after release?
|
||||
- Further textField improvements
|
||||
- Handle mouse selection
|
||||
- Create numeric wrapper that allows increasing/decreasing with mouse
|
||||
- Use new mousePress flags in scroll (instead of custom attributes)
|
||||
- ZStack should set _weIsTopLayer based on used space
|
||||
- Listview is not properly changing styles
|
||||
- Label needs to rebuild its glyphs if style/renderArea changes
|
||||
|
@ -43,6 +43,15 @@ modGS = def
|
||||
evtClick :: Point -> SystemEvent
|
||||
evtClick p = Click p LeftBtn
|
||||
|
||||
evtPress :: Point -> SystemEvent
|
||||
evtPress p = ButtonAction p LeftBtn PressedBtn
|
||||
|
||||
evtRelease :: Point -> SystemEvent
|
||||
evtRelease p = ButtonAction p LeftBtn ReleasedBtn
|
||||
|
||||
evtMove :: Point -> SystemEvent
|
||||
evtMove p = Move p
|
||||
|
||||
evtK :: KeyCode -> SystemEvent
|
||||
evtK k = KeyAction def k KeyPressed
|
||||
|
||||
|
@ -118,7 +118,7 @@ mockWenv model = WidgetEnv {
|
||||
_weGlobalKeys = M.empty,
|
||||
_weFocusedPath = rootPath,
|
||||
_weOverlayPath = Nothing,
|
||||
_wePressedPath = Nothing,
|
||||
_weMainBtnPress = Nothing,
|
||||
_weCurrentCursor = CursorArrow,
|
||||
_weModel = model,
|
||||
_weInputStatus = def,
|
||||
|
@ -18,6 +18,7 @@ import Monomer.Core.Combinators
|
||||
import Monomer.Event
|
||||
import Monomer.TestUtil
|
||||
import Monomer.TestEventUtil
|
||||
import Monomer.Widgets.Stack
|
||||
import Monomer.Widgets.TextField
|
||||
|
||||
import qualified Monomer.Lens as L
|
||||
@ -38,6 +39,7 @@ spec :: Spec
|
||||
spec = describe "TextField" $ do
|
||||
handleEvent
|
||||
handleEventValue
|
||||
handleEventMouseSelect
|
||||
handleEventHistory
|
||||
updateSizeReq
|
||||
|
||||
@ -152,6 +154,58 @@ handleEventValue = describe "handleEvent" $ do
|
||||
lastIdx es = Seq.index es (Seq.length es - 1)
|
||||
lastEvt es = lastIdx (evts es)
|
||||
|
||||
handleEventMouseSelect :: Spec
|
||||
handleEventMouseSelect = describe "handleEvent" $ do
|
||||
it "should add text at the end, since click + drag started outside of viewport" $ do
|
||||
let str = "This is text"
|
||||
let selStart = Point 50 100
|
||||
let selEnd = Point 120 10
|
||||
let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "!"]
|
||||
model steps ^. textValue `shouldBe` "This is text!"
|
||||
|
||||
it "should drag around and input 'Text'" $ do
|
||||
let str = ""
|
||||
let selStart = Point 50 10
|
||||
let selMid1 = Point 0 10
|
||||
let selMid2 = Point 200 10
|
||||
let selMid3 = Point (-200) 10
|
||||
let selEnd = Point 120 10
|
||||
let moves = [evtMove selMid1, evtMove selMid2, evtMove selMid3, evtMove selEnd]
|
||||
let steps = [evtT str, evtPress selStart] ++ moves ++ [evtRelease selEnd, evtT "Text"]
|
||||
model steps ^. textValue `shouldBe` "Text"
|
||||
|
||||
it "should input 'This is text', select 'is text' and input 'test'" $ do
|
||||
let str = "This is text"
|
||||
let selStart = Point 40 10
|
||||
let selEnd = Point 120 10
|
||||
let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "test"]
|
||||
model steps ^. textValue `shouldBe` "This test"
|
||||
|
||||
it "should input 'This is text', select all from beginning and input 'New'" $ do
|
||||
let str = "This is new"
|
||||
let selStart = Point 0 10
|
||||
let selEnd = Point 200 10
|
||||
let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "New"]
|
||||
model steps ^. textValue `shouldBe` "New"
|
||||
|
||||
it "should input 'This is text', select all from the end and input 'New'" $ do
|
||||
let str = "This is"
|
||||
let selStart = Point 70 10
|
||||
let selEnd = Point 0 10
|
||||
let steps = [evtT str, evtPress selStart, evtMove selEnd, evtRelease selEnd, evtT "New"]
|
||||
model steps ^. textValue `shouldBe` "New"
|
||||
|
||||
where
|
||||
wenv = mockWenv (TestModel "")
|
||||
txtNode = vstack [
|
||||
hstack [
|
||||
textField textValue `style` [width 105],
|
||||
hstack []
|
||||
]
|
||||
]
|
||||
model es = nodeHandleEventModel wenv es txtNode
|
||||
events es = nodeHandleEventEvts wenv es txtNode
|
||||
|
||||
handleEventHistory :: Spec
|
||||
handleEventHistory = describe "handleEventHistory" $ do
|
||||
it "should input 'This is text', have the last word removed and then undo" $ do
|
||||
|
Loading…
Reference in New Issue
Block a user