diff --git a/src/Abacus/App/Actions.hs b/src/Abacus/App/Actions.hs index 31b6c65..99dff4c 100644 --- a/src/Abacus/App/Actions.hs +++ b/src/Abacus/App/Actions.hs @@ -28,6 +28,8 @@ module Abacus.App.Actions ( -- * Rung Selection moveUp, moveDown, + topRung, + bottomRung, selRung, -- * Bead Movement beadLeft, @@ -50,6 +52,14 @@ moveDown :: AppState -> AppState moveDown s = s & rungNum %~ (min (pred $ getNumRungs $ s^.abacus) . succ) +-- | Selects the top rung +topRung :: AppState -> AppState +topRung = rungNum .~ 0 + +-- | Selects the bottom rung +bottomRung :: AppState -> AppState +bottomRung s = s & rungNum .~ pred (getNumRungs $ s^.abacus) + -- | Selectes a specified rung selRung :: Int -> AppState -> AppState selRung n s = s & rungNum .~ n' where diff --git a/src/Abacus/App/Events.hs b/src/Abacus/App/Events.hs index f6fb23e..eecfa7d 100644 --- a/src/Abacus/App/Events.hs +++ b/src/Abacus/App/Events.hs @@ -46,7 +46,17 @@ 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)) + ( Key + ( KUp + , KDown + , KLeft + , KRight + , KHome + , KEnd + , KPageUp + , KPageDown + ) + ) import Abacus.App.Actions import Abacus.App.Types @@ -68,6 +78,10 @@ eventBindings = modify moveUp , onEvent MoveDownE "Moves the cursor down" $ modify moveDown + , onEvent TopRungE "Selects the top rung" $ + modify topRung + , onEvent BottomRungE "Selects the bottom rung" $ + modify bottomRung , onEvent BeadLeftE "Moves a bead to the left" $ modify beadLeft , onEvent BeadRightE "Moves a bead to the right" $ @@ -105,6 +119,18 @@ keyBindings = , bind 'h' ] ) + , ( TopRungE + , [ shift KUp + , bind KPageUp + , bind 'K' + ] + ) + , ( BottomRungE + , [ shift KDown + , bind KPageDown + , bind 'J' + ] + ) , ( BeadRightE , [ bind KRight , bind 'l' diff --git a/src/Abacus/App/Types.hs b/src/Abacus/App/Types.hs index c33815b..9d7ddc0 100644 --- a/src/Abacus/App/Types.hs +++ b/src/Abacus/App/Types.hs @@ -54,6 +54,8 @@ data KeyEventID = QuitE | MoveUpE | MoveDownE + | TopRungE + | BottomRungE | BeadLeftE | BeadRightE | RungLeftE diff --git a/test/Abacus/App/ActionsSpec.hs b/test/Abacus/App/ActionsSpec.hs index 2ec7d0d..f1f1e42 100644 --- a/test/Abacus/App/ActionsSpec.hs +++ b/test/Abacus/App/ActionsSpec.hs @@ -33,6 +33,8 @@ spec :: Spec spec = describe "Actions" $ do moveUpSpec moveDownSpec + topRungSpec + bottomRungSpec selRungSpec beadLeftSpec beadRightSpec @@ -69,6 +71,18 @@ moveDownSpec = describe "moveDown" $ mapM_ elsewhere = initialState & rungNum .~ 8 movedDown = initialState & rungNum .~ 1 +topRungSpec :: Spec +topRungSpec = describe "topRung" $ let + state = initialState & rungNum .~ 5 + in it ("should be " ++ show initialState) $ + topRung state `shouldBe` initialState + +bottomRungSpec :: Spec +bottomRungSpec = describe "bottomRung" $ let + expected = initialState & rungNum .~ 9 + in it ("should be " ++ show expected) $ + bottomRung initialState `shouldBe` expected + selRungSpec :: Spec selRungSpec = describe "selRung" $ mapM_ ( \(desc, rung, expected) -> context desc $