Handle tab key

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

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