From 014ca39103e53a01faab4e4bd1aff6626173fbdd Mon Sep 17 00:00:00 2001 From: Jonathan Lamothe Date: Thu, 22 Aug 2024 16:14:23 -0400 Subject: [PATCH] implemented row selection --- abacus.cabal | 5 +++ package.yaml | 1 + src/Abacus/App/Actions.hs | 43 ++++++++++++++++++++++ src/Abacus/App/Events.hs | 21 ++++++++++- src/Abacus/App/Types.hs | 6 +++- test/Abacus/App/ActionsSpec.hs | 65 ++++++++++++++++++++++++++++++++++ test/Abacus/AppSpec.hs | 4 ++- 7 files changed, 142 insertions(+), 3 deletions(-) create mode 100644 src/Abacus/App/Actions.hs create mode 100644 test/Abacus/App/ActionsSpec.hs 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