diff --git a/app/Main.hs b/app/Main.hs index 61a05cae..a6ae4b24 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -31,6 +31,8 @@ import qualified Foreign.C.String as STR import qualified Graphics.Rendering.OpenGL as GL import qualified SDL import qualified SDL.Vect +import qualified SDL.Input.Keyboard as Keyboard +import qualified SDL.Input.Keyboard.Codes as KeyCodes import qualified SDL.Input.Mouse as Mouse import qualified SDL.Raw.Error as SRE @@ -179,11 +181,33 @@ currentFocus = do return (if length ring > 0 then ring!!0 else []) handleSystemEvents :: Renderer WidgetM -> [W.SystemEvent] -> TR.Path -> WidgetTree -> AppM WidgetTree -handleSystemEvents renderer systemEvents currentFocus widgets = updatedWidgets where - (stop, eventsWidgets, appEvents) = do - W.handleEvents currentFocus widgets [0] systemEvents - updatedWidgets = if | length appEvents == 0 -> return eventsWidgets - | otherwise -> handleAppEvents renderer appEvents eventsWidgets +handleSystemEvents renderer systemEvents currentFocus widgets = + foldM (\newWidgets event -> handleSystemEvent renderer event currentFocus newWidgets) widgets systemEvents + +handleSystemEvent :: Renderer WidgetM -> W.SystemEvent -> TR.Path -> WidgetTree -> AppM WidgetTree +handleSystemEvent renderer systemEvent currentFocus widgets = do + let (stop, eventsWidgets, appEvents) = W.handleEvent currentFocus widgets [0] systemEvent + + when (not stop && W.isKeyPressed systemEvent keycodeTab) $ do + ring <- use focusRing + focusRing .= rotateList ring + + if length appEvents == 0 then + return eventsWidgets + else + handleAppEvents renderer appEvents eventsWidgets + +rotateList :: [a] -> [a] +rotateList [] = [] +rotateList (x:xs) = xs ++ [x] + +keycodeTab = fromIntegral $ Keyboard.unwrapKeycode SDL.KeycodeTab + +isKeyTab :: W.KeyCode -> Bool +isKeyTab key = matchesSDLKeyCode key SDL.KeycodeTab + +matchesSDLKeyCode :: W.KeyCode -> SDL.Keycode -> Bool +matchesSDLKeyCode keyCode sdlKeyCode = keyCode == (fromIntegral $ Keyboard.unwrapKeycode sdlKeyCode) handleAppEvents :: Renderer WidgetM -> SQ.Seq AppEvent -> WidgetTree -> AppM WidgetTree handleAppEvents renderer appEvents oldWidgets = do diff --git a/src/GUI/Widget/Core.hs b/src/GUI/Widget/Core.hs index d0d13727..641fb472 100644 --- a/src/GUI/Widget/Core.hs +++ b/src/GUI/Widget/Core.hs @@ -36,6 +36,10 @@ data SystemEvent = Update Timestamp | Click Point Button ButtonState | KeyAction KeyCode KeyMotion deriving (Show, Eq) +isKeyPressed :: SystemEvent -> KeyCode -> Bool +isKeyPressed (KeyAction keyCode KeyPressed) keyCodeChecked = keyCode == keyCodeChecked +isKeyPressed _ _ = False + data WidgetEventResult s e m = WidgetEventResult { _eventResultStop :: Bool, _eventResultUserEvents :: [e], @@ -203,16 +207,15 @@ mergeTrees node1@(Node widget1 seq1) (Node widget2 seq2) = newNode where addedChildren = SQ.drop (SQ.length seq2) seq1 mergeChild = \(c1, c2) -> mergeTrees c1 c2 -handleWidgetEvents :: (MonadState s m, Traversable t) => Widget s e m -> Rect -> Focused -> t SystemEvent -> Maybe (WidgetEventResult s e m) -handleWidgetEvents (Widget {..}) viewport focused systemEvents = - foldl (\widgetEvent systemEvent -> widgetEvent <> _widgetHandleEvent viewport focused systemEvent) Nothing systemEvents +handleWidgetEvents :: (MonadState s m) => Widget s e m -> Rect -> Focused -> SystemEvent -> Maybe (WidgetEventResult s e m) +handleWidgetEvents (Widget {..}) viewport focused systemEvent = _widgetHandleEvent viewport focused systemEvent -handleEvents :: (MonadState s m, Traversable t) => Path -> Tree (WidgetNode s e m) -> Path -> t SystemEvent -> (Bool, Tree (WidgetNode s e m), SQ.Seq e) -handleEvents focusedPath (Node (wn@WidgetNode { .. }) children) currentPath systemEvents = (newStop, newNode, childEvents) where +handleEvent :: (MonadState s m) => Path -> Tree (WidgetNode s e m) -> Path -> SystemEvent -> (Bool, Tree (WidgetNode s e m), SQ.Seq e) +handleEvent focusedPath (Node (wn@WidgetNode { .. }) children) currentPath systemEvents = (newStop, newNode, childEvents) where (stop, userEvents, newWidget) = case handleWidgetEvents _widgetNodeWidget _widgetNodeViewport (focusedPath == currentPath) systemEvents of Nothing -> (False, [], _widgetNodeWidget) Just (WidgetEventResult {..}) -> (_eventResultStop, _eventResultUserEvents, fromMaybe _widgetNodeWidget _eventResultNewWidget) - (newStop, newChildren, childEvents, _) = foldl (\(st, ws, evs, idx) widgetNode -> case handleEvents focusedPath widgetNode (idx : currentPath) systemEvents of + (newStop, newChildren, childEvents, _) = foldl (\(st, ws, evs, idx) widgetNode -> case handleEvent focusedPath widgetNode (idx : currentPath) systemEvents of (st2, ws2, evs2) -> (st || st2, ws SQ.|> ws2, evs SQ.>< evs2, idx + 1)) (stop, SQ.empty, SQ.fromList userEvents, 0) children newNode = Node (wn { _widgetNodeWidget = newWidget }) newChildren