diff --git a/abacus.cabal b/abacus.cabal
index 010172d..471f47f 100644
--- a/abacus.cabal
+++ b/abacus.cabal
@@ -21,6 +21,7 @@ library
exposed-modules:
Abacus
Abacus.App
+ Abacus.App.Actions
Abacus.App.Events
Abacus.App.Types
Abacus.App.Widgets
@@ -37,6 +38,7 @@ library
base >=4.7 && <5
, brick >=2.1.1 && <2.2
, microlens-platform >=0.4.3.5 && <0.5
+ , mtl >=2.3.1 && <2.4
, vty ==6.1.*
default-language: Haskell2010
@@ -54,6 +56,7 @@ executable abacus
, base >=4.7 && <5
, brick >=2.1.1 && <2.2
, microlens-platform >=0.4.3.5 && <0.5
+ , mtl >=2.3.1 && <2.4
, vty ==6.1.*
default-language: Haskell2010
@@ -61,6 +64,7 @@ test-suite abacus-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
+ Abacus.App.ActionsSpec
Abacus.App.Widgets.InternalSpec
Abacus.App.WidgetsSpec
Abacus.AppSpec
@@ -77,5 +81,6 @@ test-suite abacus-test
, brick >=2.1.1 && <2.2
, hspec >=2.11.9 && <2.12
, microlens-platform >=0.4.3.5 && <0.5
+ , mtl >=2.3.1 && <2.4
, vty ==6.1.*
default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index 7a1b60e..32c0ea3 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
+- mtl >= 2.3.1 && < 2.4
- vty >= 6.1 && < 6.2
ghc-options:
diff --git a/src/Abacus/App/Actions.hs b/src/Abacus/App/Actions.hs
new file mode 100644
index 0000000..d6495e8
--- /dev/null
+++ b/src/Abacus/App/Actions.hs
@@ -0,0 +1,43 @@
+{-|
+
+Module : Abacus.App.Actions
+Description : Transformations on the applicaiton state
+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
+.
+
+-}
+
+module Abacus.App.Actions (moveUp, moveDown) where
+
+import Lens.Micro.Platform ((^.), (&), (%~))
+
+import Abacus
+import Abacus.App.Types
+
+-- Moves the cursor up
+moveUp :: AppState -> AppState
+moveUp = rungNum %~ (max 0 . pred)
+
+-- Moves the cursor down
+moveDown :: AppState -> AppState
+moveDown s = s & rungNum %~
+ (min (pred $ getNumRungs $ s^.abacus) . succ)
+
+--jl
diff --git a/src/Abacus/App/Events.hs b/src/Abacus/App/Events.hs
index 51778b6..6cd5f18 100644
--- a/src/Abacus/App/Events.hs
+++ b/src/Abacus/App/Events.hs
@@ -42,8 +42,11 @@ import Brick.Keybindings
, newKeyConfig
, onEvent
)
+import Control.Monad.State.Class (modify)
import Data.Either (fromRight)
+import Graphics.Vty.Input.Events (Key (KUp, KDown))
+import Abacus.App.Actions
import Abacus.App.Types
-- | Application keyboard configuration
@@ -57,7 +60,13 @@ keyConfig = newKeyConfig appKeyEvents keyBindings []
-- | Binds a "KeyEventID" to its associated action
eventBindings :: [KeyEventHandler KeyEventID (EventM () AppState)]
-eventBindings = [onEvent QuitE "Quits the program" halt]
+eventBindings =
+ [ onEvent QuitE "Quits the program" halt
+ , onEvent MoveUpE "Moves the cursor up" $
+ modify moveUp
+ , onEvent MoveDownE "Moves the cursor down" $
+ modify moveDown
+ ]
-- | Names the individual key events
appKeyEvents :: KeyEvents KeyEventID
@@ -71,6 +80,16 @@ keyBindings =
, bind 'q'
]
)
+ , ( MoveUpE
+ , [ bind KUp
+ , bind 'k'
+ ]
+ )
+ , ( MoveDownE
+ , [ bind KDown
+ , bind 'j'
+ ]
+ )
]
--jl
diff --git a/src/Abacus/App/Types.hs b/src/Abacus/App/Types.hs
index 470bc91..6cdfbee 100644
--- a/src/Abacus/App/Types.hs
+++ b/src/Abacus/App/Types.hs
@@ -50,7 +50,11 @@ data AppState = AppState
} deriving (Eq, Show)
-- | Identifiers for various key events
-data KeyEventID = QuitE deriving (Eq, Ord, Show)
+data KeyEventID
+ = QuitE
+ | MoveUpE
+ | MoveDownE
+ deriving (Eq, Ord, Show)
makeLenses ''AppState
diff --git a/test/Abacus/App/ActionsSpec.hs b/test/Abacus/App/ActionsSpec.hs
new file mode 100644
index 0000000..b5afc2d
--- /dev/null
+++ b/test/Abacus/App/ActionsSpec.hs
@@ -0,0 +1,65 @@
+{-
+
+abacus
+Copyright (C) Jonathan Lamothe
+
+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
+.
+
+-}
+
+module Abacus.App.ActionsSpec (spec) where
+
+import Lens.Micro.Platform ((&), (.~))
+import Test.Hspec (Spec, context, describe, it, shouldBe)
+
+import Abacus.App.Actions
+import Abacus.App.Types
+
+spec :: Spec
+spec = describe "Actions" $ do
+ moveUpSpec
+ moveDownSpec
+
+moveUpSpec :: Spec
+moveUpSpec = describe "moveUp" $ mapM_
+ ( \(desc, state, expected) -> context desc $
+ it ("should be " ++ show expected) $
+ moveUp state `shouldBe` expected
+ )
+ [ ( "at the top", initialState, initialState )
+ , ( "at the bottom", atBottom, movedUp )
+ , ( "somewhere else", elsewhere, initialState )
+ ]
+ where
+ atBottom = initialState & rungNum .~ 9
+ elsewhere = initialState & rungNum .~ 1
+ movedUp = initialState & rungNum .~ 8
+
+moveDownSpec :: Spec
+moveDownSpec = describe "moveDown" $ mapM_
+ ( \(desc, state, expected) -> context desc $
+ it ("should be " ++ show expected) $
+ moveDown state `shouldBe` expected
+ )
+ [ ( "at the top", initialState, movedDown )
+ , ( "at the bottom", atBottom, atBottom )
+ , ( "somewhere else", elsewhere, atBottom )
+ ]
+ where
+ atBottom = initialState & rungNum .~ 9
+ elsewhere = initialState & rungNum .~ 8
+ movedDown = initialState & rungNum .~ 1
+
+--jl
diff --git a/test/Abacus/AppSpec.hs b/test/Abacus/AppSpec.hs
index a36f65e..2440f89 100644
--- a/test/Abacus/AppSpec.hs
+++ b/test/Abacus/AppSpec.hs
@@ -23,10 +23,12 @@ module Abacus.AppSpec (spec) where
import Test.Hspec (Spec, describe)
+import qualified Abacus.App.ActionsSpec as Actions
import qualified Abacus.App.WidgetsSpec as Widgets
spec :: Spec
-spec = describe "App"
+spec = describe "App" $ do
Widgets.spec
+ Actions.spec
--jl