Refactor event preprocessing logic (move from Core to Handlers). Add text selection unit tests

.hlint.yaml

@@ -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

src/Monomer/Main/Core.hs

@@ -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 ]

src/Monomer/Main/Handlers.hs

@@ -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
 

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

test/unit/Monomer/TestEventUtil.hs

@@ -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
 

test/unit/Monomer/TestUtil.hs

@@ -118,7 +118,7 @@ mockWenv model = WidgetEnv {
   _weGlobalKeys = M.empty,
   _weFocusedPath = rootPath,
   _weOverlayPath = Nothing,
-  _wePressedPath = Nothing,
+  _weMainBtnPress = Nothing,
   _weCurrentCursor = CursorArrow,
   _weModel = model,
   _weInputStatus = def,

test/unit/Monomer/Widgets/TextFieldSpec.hs

@@ -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