use keybindings funcitonality
This commit is contained in:
parent
26436538c7
commit
6426057571
|
@ -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
|
||||
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 ()
|
||||
|
||||
displayHandler :: Handler
|
||||
displayHandler (VtyEvent (EvKey (KChar 'e') [])) =
|
||||
appMode .= EditMode initialEditor
|
||||
displayHandler _ = 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']
|
||||
)
|
||||
]
|
||||
|
||||
editHandler :: Handler
|
||||
editHandler (VtyEvent (EvKey KEsc [])) =
|
||||
appMode .= DisplayMode
|
||||
editHandler (VtyEvent (EvKey KUp [])) =
|
||||
appMode.editState %= moveUp
|
||||
editHandler (VtyEvent (EvKey (KChar 'k') [])) =
|
||||
appMode.editState %= moveUp
|
||||
editHandler (VtyEvent (EvKey KDown [])) =
|
||||
appMode.editState %= moveDown
|
||||
editHandler (VtyEvent (EvKey (KChar 'j') [])) =
|
||||
appMode.editState %= moveDown
|
||||
editHandler (VtyEvent (EvKey KLeft [])) =
|
||||
appMode.editState %= moveLeft
|
||||
editHandler (VtyEvent (EvKey (KChar 'h') [])) =
|
||||
appMode.editState %= moveLeft
|
||||
editHandler (VtyEvent (EvKey KRight [])) =
|
||||
appMode.editState %= moveRight
|
||||
editHandler (VtyEvent (EvKey (KChar 'l') [])) =
|
||||
appMode.editState %= moveRight
|
||||
editHandler (VtyEvent (EvKey (KChar 'f') [])) =
|
||||
modify flipBit
|
||||
editHandler _ = return ()
|
||||
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
|
||||
|
|
|
@ -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 = ()
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user