expose keybinding data

src/Hamming/App/Events.hs

@@ -26,11 +26,17 @@ License along with this program.  If not, see
 
 {-# LANGUAGE LambdaCase, OverloadedStrings #-}
 
-module Hamming.App.Events (eventHandler) where
+module Hamming.App.Events (
+  eventHandler,
+  keyConfigFor,
+  keyEventHandlers
+  ) where
 
-import Brick (BrickEvent (..), halt, )
+import Brick (BrickEvent (..), EventM, halt)
 import Brick.Keybindings
   ( Binding
+  , KeyConfig
+  , KeyEventHandler
   , KeyEvents
   , bind
   , ctrl
@@ -54,8 +60,51 @@ import Hamming
 import Hamming.App.Actions
 import Hamming.App.Types
 
-appEvents :: KeyEvents AppEvent
+-- | Handles an event
-appEvents = keyEvents
+eventHandler :: Handler
+eventHandler (VtyEvent (EvKey k m)) = do
+  config <- keyConfigFor <$> gets (^.appMode)
+  let
+    disp = fromRight (error "can't built dispatcher") $
+      keyDispatcher config keyEventHandlers
+  void $ handleKey disp k m
+eventHandler _ = return ()
+
+-- | The key configuration from a given applicaiton mode
+keyConfigFor :: AppMode -> KeyConfig AppKeyEvent
+keyConfigFor m = newKeyConfig appKeyEvents (keyBindingsFor m) []
+
+-- | Defines the actual key events
+keyEventHandlers :: [KeyEventHandler AppKeyEvent (EventM ResName AppState)]
+keyEventHandlers =
+  [ onEvent QuitEvent "Quit Program" halt
+  , onEvent EditEvent "Edit Mode" $
+    appMode .= EditMode initialEditor
+  , onEvent DisplayEvent "Display Mode" $
+    appMode .= DisplayMode
+  , onEvent UpEvent "Cursor Up" $
+    appMode.editState %= moveUp
+  , onEvent DownEvent "Cursor Down" $
+    appMode.editState %= moveDown
+  , onEvent LeftEvent "Cursor Left" $
+    appMode.editState %= moveLeft
+  , onEvent RightEvent "Cursor Right" $
+    appMode.editState %= moveRight
+  , onEvent FlipBitEvent "Flip Selected Bit" $
+    modify flipBit
+  , onEvent CheckBitsEvent "Set Check Bits" $
+    hammingCode %= setCheckBits
+  , onEvent FixCodeEvent "Attempt to Correct Errors" $
+    zoom hammingCode $ get >>= \case
+      Nothing -> return ()
+      Just c  -> put c
+      . correctErrors
+  , onEvent ResetEvent "Reset Code" $
+    hammingCode .= 0
+  ]
+
+appKeyEvents :: KeyEvents AppKeyEvent
+appKeyEvents = keyEvents
   [ ( "quit",     QuitEvent      )
   , ( "edit",     EditEvent      )
   , ( "display",  DisplayEvent   )
@@ -69,43 +118,8 @@ appEvents = keyEvents
   , ( "reset",    ResetEvent     )
   ]
 
--- | Handles an event
+keyBindingsFor :: AppMode -> [(AppKeyEvent, [Binding])]
-eventHandler :: Handler
+keyBindingsFor m = coreBindings ++ case m of
-eventHandler (VtyEvent (EvKey k m)) = do
-  bs <- bindingsFor <$> gets (^.appMode)
-  let
-    kConf = newKeyConfig appEvents bs []
-    disp  = fromRight (error "can't build dispatcher") $ keyDispatcher kConf
-      [ onEvent QuitEvent "Quit Program" halt
-      , onEvent EditEvent "Edit Mode" $
-        appMode .= EditMode initialEditor
-      , onEvent DisplayEvent "Display Mode" $
-        appMode .= DisplayMode
-      , onEvent UpEvent "Cursor Up" $
-        appMode.editState %= moveUp
-      , onEvent DownEvent "Cursor Down" $
-        appMode.editState %= moveDown
-      , onEvent LeftEvent "Cursor Left" $
-        appMode.editState %= moveLeft
-      , onEvent RightEvent "Cursor Right" $
-        appMode.editState %= moveRight
-      , onEvent FlipBitEvent "Flip Selected Bit" $
-        modify flipBit
-      , onEvent CheckBitsEvent "Set Check Bits" $
-        hammingCode %= setCheckBits
-      , onEvent FixCodeEvent "Attempt to Correct Errors" $
-        zoom hammingCode $ get >>= \case
-          Nothing -> return ()
-          Just c  -> put c
-          . correctErrors
-      , onEvent ResetEvent "Reset Code" $
-        hammingCode .= 0
-      ]
-  void $ handleKey disp k m
-eventHandler _ = return ()
-
-bindingsFor :: AppMode -> [(AppEvent, [Binding])]
-bindingsFor m = coreBindings ++ case m of
   DisplayMode -> displayBindings
   EditMode _  -> editBindings
   where

src/Hamming/App/Types.hs

@@ -43,7 +43,7 @@ module Hamming.App.Types (
   rowNum,
   colNum,
   -- * Event Types
-  AppEvent (..),
+  AppKeyEvent (..),
   -- * Other Types
   ResName,
   Event,
@@ -81,7 +81,7 @@ data EditState = EditState
   } deriving (Eq, Show)
 
 -- | Event identifiers
-data AppEvent
+data AppKeyEvent
   = QuitEvent
   | EditEvent
   | DisplayEvent