use keybindings funcitonality

src/Hamming/App/Events.hs

@@ -24,17 +24,28 @@ License along with this program.  If not, see
 
 |-}
 
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedStrings #-}
 
 module Hamming.App.Events (eventHandler) where
 
-import Brick.Main (halt)
+import Brick (BrickEvent (..), halt, )
-import Brick.Types (BrickEvent (VtyEvent), gets, modify)
+import Brick.Keybindings
-import Control.Monad.State.Class (put)
+  ( Binding
+  , KeyEvents
+  , bind
+  , ctrl
+  , handleKey
+  , keyDispatcher
+  , keyEvents
+  , newKeyConfig
+  , onEvent
+  )
+import Control.Monad (void)
+import Control.Monad.State.Class (get, gets, modify, put)
+import Data.Either (fromRight)
 import Graphics.Vty.Input.Events
   ( Event (EvKey)
   , Key (..)
-  , Modifier (MCtrl)
   )
 import Lens.Micro ((^.))
 import Lens.Micro.Mtl (zoom, (.=), (%=))
@@ -43,48 +54,115 @@ import Hamming
 import Hamming.App.Actions
 import Hamming.App.Types
 
+appEvents :: KeyEvents AppEvent
+appEvents = keyEvents
+  [ ( "quit",     QuitEvent      )
+  , ( "edit",     EditEvent      )
+  , ( "display",  DisplayEvent   )
+  , ( "up",       UpEvent        )
+  , ( "down",     DownEvent      )
+  , ( "left",     LeftEvent      )
+  , ( "right",    RightEvent     )
+  , ( "flip_bit", FlipBitEvent   )
+  , ( "chk_bits", CheckBitsEvent )
+  , ( "fix_code", FixCodeEvent   )
+  , ( "reset",    ResetEvent     )
+  ]
+
 -- | Handles an event
 eventHandler :: Handler
-eventHandler (VtyEvent (EvKey (KChar 'c') [MCtrl])) = halt
+eventHandler (VtyEvent (EvKey k m)) = do
-eventHandler (VtyEvent (EvKey (KChar 'q') [])) = halt
+  bs <- bindingsFor <$> gets (^.appMode)
-eventHandler (VtyEvent (EvKey (KChar 'c') [])) =
+  let
-  hammingCode %= setCheckBits
+    kConf = newKeyConfig appEvents bs []
-eventHandler (VtyEvent (EvKey (KChar 'v') [])) =
+    disp  = fromRight (error "can't build dispatcher") $ keyDispatcher kConf
-  zoom hammingCode $ gets correctErrors >>= \case
+      [ onEvent QuitEvent "Quit Program" halt
-    Just c  -> put c
+      , onEvent EditEvent "Edit Mode" $
-    Nothing -> return ()
-eventHandler (VtyEvent (EvKey (KChar 'r') [])) =
-  hammingCode .= 0
-eventHandler e = gets (^.appMode) >>= \case
-  DisplayMode -> displayHandler e
-  EditMode _  -> editHandler e
-
-displayHandler :: Handler
-displayHandler (VtyEvent (EvKey (KChar 'e') [])) =
         appMode .= EditMode initialEditor
-displayHandler _ = return ()
+      , onEvent DisplayEvent "Display Mode" $
-
-editHandler :: Handler
-editHandler (VtyEvent (EvKey KEsc [])) =
         appMode .= DisplayMode
-editHandler (VtyEvent (EvKey KUp [])) =
+      , onEvent UpEvent "Cursor Up" $
         appMode.editState %= moveUp
-editHandler (VtyEvent (EvKey (KChar 'k') [])) =
+      , onEvent DownEvent "Cursor Down" $
-  appMode.editState %= moveUp
-editHandler (VtyEvent (EvKey KDown [])) =
         appMode.editState %= moveDown
-editHandler (VtyEvent (EvKey (KChar 'j') [])) =
+      , onEvent LeftEvent "Cursor Left" $
-  appMode.editState %= moveDown
-editHandler (VtyEvent (EvKey KLeft [])) =
         appMode.editState %= moveLeft
-editHandler (VtyEvent (EvKey (KChar 'h') [])) =
+      , onEvent RightEvent "Cursor Right" $
-  appMode.editState %= moveLeft
-editHandler (VtyEvent (EvKey KRight [])) =
         appMode.editState %= moveRight
-editHandler (VtyEvent (EvKey (KChar 'l') [])) =
+      , onEvent FlipBitEvent "Flip Selected Bit" $
-  appMode.editState %= moveRight
-editHandler (VtyEvent (EvKey (KChar 'f') [])) =
         modify flipBit
-editHandler _ = return ()
+      , 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
+    coreBindings =
+      [ ( QuitEvent
+        , [ ctrl 'c'
+          , bind 'q'
+          ]
+        )
+      , ( CheckBitsEvent
+        , [bind 'c']
+        )
+      , ( FixCodeEvent
+        , [bind 'v']
+        )
+      , ( ResetEvent
+        , [bind 'r']
+        )
+      ]
+
+    displayBindings =
+      [ ( EditEvent
+        , [bind 'e']
+        )
+      ]
+
+    editBindings =
+      [ ( DisplayEvent
+        , [bind KEsc]
+        )
+      , ( UpEvent
+        , [ bind KUp
+          , ctrl 'p'
+          , bind 'k'
+          ]
+        )
+      , ( DownEvent
+        , [ bind KDown
+          , ctrl 'n'
+          , bind 'j'
+          ]
+        )
+      , ( LeftEvent
+        , [ bind KLeft
+          , ctrl 'p'
+          , bind 'h'
+          ]
+        )
+      , ( RightEvent
+        , [ bind KRight
+          , ctrl 'f'
+          , bind 'l'
+          ]
+        )
+      , ( FlipBitEvent
+        , [bind 'f']
+        )
+      ]
 
 --jl

src/Hamming/App/Types.hs

@@ -42,6 +42,8 @@ module Hamming.App.Types (
   -- *** Lenses
   rowNum,
   colNum,
+  -- * Event Types
+  AppEvent (..),
   -- * Other Types
   ResName,
   Event,
@@ -78,6 +80,21 @@ data EditState = EditState
   -- ^ The selected column
   } deriving (Eq, Show)
 
+-- | Event identifiers
+data AppEvent
+  = QuitEvent
+  | EditEvent
+  | DisplayEvent
+  | UpEvent
+  | DownEvent
+  | LeftEvent
+  | RightEvent
+  | FlipBitEvent
+  | CheckBitsEvent
+  | FixCodeEvent
+  | ResetEvent
+  deriving (Eq, Ord, Show)
+
 -- | Identifies a resource
 type ResName = ()