From 6a4a1fda82924efe7051ccc1929be900e17a41c1 Mon Sep 17 00:00:00 2001
From: Jonathan Lamothe <jonathan@jlamothe.net>
Date: Thu, 22 Aug 2024 15:09:42 -0400
Subject: [PATCH] implemented keyboard handler

---
 abacus.cabal             |  4 +++
 package.yaml             |  1 +
 src/Abacus/App.hs        | 11 ++++--
 src/Abacus/App/Events.hs | 76 ++++++++++++++++++++++++++++++++++++++++
 src/Abacus/App/Types.hs  |  4 +++
 5 files changed, 93 insertions(+), 3 deletions(-)
 create mode 100644 src/Abacus/App/Events.hs

diff --git a/abacus.cabal b/abacus.cabal
index c832721..010172d 100644
--- a/abacus.cabal
+++ b/abacus.cabal
@@ -21,6 +21,7 @@ library
   exposed-modules:
       Abacus
       Abacus.App
+      Abacus.App.Events
       Abacus.App.Types
       Abacus.App.Widgets
       Abacus.App.Widgets.Internal
@@ -36,6 +37,7 @@ library
       base >=4.7 && <5
     , brick >=2.1.1 && <2.2
     , microlens-platform >=0.4.3.5 && <0.5
+    , vty ==6.1.*
   default-language: Haskell2010
 
 executable abacus
@@ -52,6 +54,7 @@ executable abacus
     , base >=4.7 && <5
     , brick >=2.1.1 && <2.2
     , microlens-platform >=0.4.3.5 && <0.5
+    , vty ==6.1.*
   default-language: Haskell2010
 
 test-suite abacus-test
@@ -74,4 +77,5 @@ test-suite abacus-test
     , brick >=2.1.1 && <2.2
     , hspec >=2.11.9 && <2.12
     , microlens-platform >=0.4.3.5 && <0.5
+    , vty ==6.1.*
   default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index cc8ae38..7a1b60e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -22,6 +22,7 @@ dependencies:
 - base >= 4.7 && < 5
 - brick >= 2.1.1 && < 2.2
 - microlens-platform >= 0.4.3.5 && < 0.5
+- vty >= 6.1 && < 6.2
 
 ghc-options:
 - -Wall
diff --git a/src/Abacus/App.hs b/src/Abacus/App.hs
index 9d66ff5..eb32d32 100644
--- a/src/Abacus/App.hs
+++ b/src/Abacus/App.hs
@@ -28,16 +28,19 @@ module Abacus.App (mainApp) where
 
 import Brick
   ( App (..)
-  , BrickEvent
+  , BrickEvent (VtyEvent)
   , EventM
   , Widget
   , attrMap
-  , halt
   , neverShowCursor
   , style
   )
+import Brick.Keybindings (handleKey)
 import Brick.Widgets.Center (center)
+import Control.Monad (void)
+import Graphics.Vty.Input.Events (Event (EvKey))
 
+import Abacus.App.Events
 import Abacus.App.Types
 import Abacus.App.Widgets
 
@@ -55,6 +58,8 @@ drawFunc :: AppState -> [Widget ()]
 drawFunc s = [center $ abacusW s]
 
 eventHandler :: BrickEvent () () -> EventM () AppState ()
-eventHandler = const halt
+eventHandler (VtyEvent (EvKey k m)) =
+  void $ handleKey appKeyDispatcher k m
+eventHandler _ = return ()
 
 --jl
diff --git a/src/Abacus/App/Events.hs b/src/Abacus/App/Events.hs
new file mode 100644
index 0000000..51778b6
--- /dev/null
+++ b/src/Abacus/App/Events.hs
@@ -0,0 +1,76 @@
+{-|
+
+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
+  , KeyEvents
+  , bind
+  , ctrl
+  , keyDispatcher
+  , keyEvents
+  , newKeyConfig
+  , onEvent
+  )
+import Data.Either (fromRight)
+
+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 appKeyEvents keyBindings []
+
+-- | Binds a "KeyEventID" to its associated action
+eventBindings :: [KeyEventHandler KeyEventID (EventM () AppState)]
+eventBindings = [onEvent QuitE "Quits the program" halt]
+
+-- | Names the individual key events
+appKeyEvents :: KeyEvents KeyEventID
+appKeyEvents = keyEvents [( "quit", QuitE )]
+
+-- | Key bindings
+keyBindings :: [(KeyEventID, [Binding])]
+keyBindings =
+  [ ( QuitE
+    , [ ctrl 'c'
+      , bind 'q'
+      ]
+    )
+  ]
+
+--jl
diff --git a/src/Abacus/App/Types.hs b/src/Abacus/App/Types.hs
index 52c0dfd..470bc91 100644
--- a/src/Abacus/App/Types.hs
+++ b/src/Abacus/App/Types.hs
@@ -28,6 +28,7 @@ License along with this program.  If not, see
 
 module Abacus.App.Types (
   AppState (..),
+  KeyEventID (..),
   -- * Lenses
   abacus,
   rungNum,
@@ -48,6 +49,9 @@ data AppState = AppState
   -- ^ The selected rung number
   } deriving (Eq, Show)
 
+-- | Identifiers for various key events
+data KeyEventID = QuitE deriving (Eq, Ord, Show)
+
 makeLenses ''AppState
 
 -- | Initial application state