134 lines
3.1 KiB
Haskell
134 lines
3.1 KiB
Haskell
{-|
|
|
|
|
Module : Abacus.App.Events
|
|
Description : Application event handling
|
|
Copyright : (C) Jonathan Lamothe
|
|
License : AGPL-3.0-or-later
|
|
Maintainer : jonathan@jlamothe.net
|
|
Stability : experimental
|
|
Portability : POSIX
|
|
|
|
This program is free software: you can redistribute it and/or modify
|
|
it under the terms of the GNU Affero General Public License as
|
|
published by the Free Software Foundation, either version 3 of the
|
|
License, or (at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
Affero General Public License for more details.
|
|
|
|
You should have received a copy of the GNU Affero General Public
|
|
License along with this program. If not, see
|
|
<https://www.gnu.org/licenses/>.
|
|
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Abacus.App.Events (appKeyDispatcher) where
|
|
|
|
import Brick (EventM, halt)
|
|
import Brick.Keybindings
|
|
( Binding
|
|
, KeyConfig
|
|
, KeyDispatcher
|
|
, KeyEventHandler
|
|
, bind
|
|
, ctrl
|
|
, keyDispatcher
|
|
, keyEvents
|
|
, newKeyConfig
|
|
, onEvent
|
|
, shift
|
|
)
|
|
import Control.Monad.State.Class (modify)
|
|
import Data.Char (chr, ord)
|
|
import Data.Either (fromRight)
|
|
import Graphics.Vty.Input.Events
|
|
(Key (KUp, KDown, KLeft, KRight, KHome, KEnd))
|
|
|
|
import Abacus.App.Actions
|
|
import Abacus.App.Types
|
|
|
|
-- | Application keyboard configuration
|
|
appKeyDispatcher :: KeyDispatcher KeyEventID (EventM () AppState)
|
|
appKeyDispatcher = fromRight (error "can't build key dispatcher") $
|
|
keyDispatcher keyConfig eventBindings
|
|
|
|
-- | The key configuration
|
|
keyConfig :: KeyConfig KeyEventID
|
|
keyConfig = newKeyConfig (keyEvents []) keyBindings []
|
|
|
|
-- | Binds a "KeyEventID" to its associated action
|
|
eventBindings :: [KeyEventHandler KeyEventID (EventM () AppState)]
|
|
eventBindings =
|
|
[ onEvent QuitE "Quits the program" halt
|
|
, onEvent MoveUpE "Moves the cursor up" $
|
|
modify moveUp
|
|
, onEvent MoveDownE "Moves the cursor down" $
|
|
modify moveDown
|
|
, onEvent BeadLeftE "Moves a bead to the left" $
|
|
modify beadLeft
|
|
, onEvent BeadRightE "Moves a bead to the right" $
|
|
modify beadRight
|
|
, onEvent RungLeftE "Moves all beads to the left of the rung" $
|
|
modify rungLeft
|
|
, onEvent RungRightE "Moves all beads to the right of the rung" $
|
|
modify rungRight
|
|
] ++ map
|
|
( \n -> onEvent (SelRungE n) "Moves to a numbered rung" $
|
|
modify $ selRung n
|
|
)
|
|
[0..9]
|
|
|
|
-- | Key bindings
|
|
keyBindings :: [(KeyEventID, [Binding])]
|
|
keyBindings =
|
|
[ ( QuitE
|
|
, [ ctrl 'c'
|
|
, bind 'q'
|
|
]
|
|
)
|
|
, ( MoveUpE
|
|
, [ bind KUp
|
|
, bind 'k'
|
|
]
|
|
)
|
|
, ( MoveDownE
|
|
, [ bind KDown
|
|
, bind 'j'
|
|
]
|
|
)
|
|
, ( BeadLeftE
|
|
, [ bind KLeft
|
|
, bind 'h'
|
|
]
|
|
)
|
|
, ( BeadRightE
|
|
, [ bind KRight
|
|
, bind 'l'
|
|
]
|
|
)
|
|
, ( RungLeftE
|
|
, [ shift KLeft
|
|
, bind KHome
|
|
, bind 'H'
|
|
]
|
|
)
|
|
, ( RungRightE
|
|
, [ shift KRight
|
|
, bind KEnd
|
|
, bind 'L'
|
|
]
|
|
)
|
|
] ++ map
|
|
( \n ->
|
|
( SelRungE n
|
|
, [bind $ chr $ ord '0' + n]
|
|
)
|
|
)
|
|
[0..9]
|
|
|
|
--jl
|