implemented moving to top and bottom rungs
This commit is contained in:
parent
04e90481de
commit
2f50ed51be
|
@ -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
|
||||
|
|
|
@ -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'
|
||||
|
|
|
@ -54,6 +54,8 @@ data KeyEventID
|
|||
= QuitE
|
||||
| MoveUpE
|
||||
| MoveDownE
|
||||
| TopRungE
|
||||
| BottomRungE
|
||||
| BeadLeftE
|
||||
| BeadRightE
|
||||
| RungLeftE
|
||||
|
|
|
@ -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 $
|
||||
|
|
Loading…
Reference in New Issue
Block a user