use keybindings funcitonality

This commit is contained in:
Jonathan Lamothe 2024-08-13 13:52:55 -04:00
parent 26436538c7
commit 6426057571
2 changed files with 139 additions and 44 deletions

View File

@ -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.Types (BrickEvent (VtyEvent), gets, modify)
import Control.Monad.State.Class (put)
import Brick (BrickEvent (..), halt, )
import Brick.Keybindings
( 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 (KChar 'q') [])) = halt
eventHandler (VtyEvent (EvKey (KChar 'c') [])) =
hammingCode %= setCheckBits
eventHandler (VtyEvent (EvKey (KChar 'v') [])) =
zoom hammingCode $ gets correctErrors >>= \case
Just c -> put c
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') [])) =
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
displayHandler _ = return ()
editHandler :: Handler
editHandler (VtyEvent (EvKey KEsc [])) =
, onEvent DisplayEvent "Display Mode" $
appMode .= DisplayMode
editHandler (VtyEvent (EvKey KUp [])) =
, onEvent UpEvent "Cursor Up" $
appMode.editState %= moveUp
editHandler (VtyEvent (EvKey (KChar 'k') [])) =
appMode.editState %= moveUp
editHandler (VtyEvent (EvKey KDown [])) =
, onEvent DownEvent "Cursor Down" $
appMode.editState %= moveDown
editHandler (VtyEvent (EvKey (KChar 'j') [])) =
appMode.editState %= moveDown
editHandler (VtyEvent (EvKey KLeft [])) =
, onEvent LeftEvent "Cursor Left" $
appMode.editState %= moveLeft
editHandler (VtyEvent (EvKey (KChar 'h') [])) =
appMode.editState %= moveLeft
editHandler (VtyEvent (EvKey KRight [])) =
, onEvent RightEvent "Cursor Right" $
appMode.editState %= moveRight
editHandler (VtyEvent (EvKey (KChar 'l') [])) =
appMode.editState %= moveRight
editHandler (VtyEvent (EvKey (KChar 'f') [])) =
, onEvent FlipBitEvent "Flip Selected Bit" $
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

View File

@ -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 = ()