diff options
-rw-r--r-- | src/Xanthous/App.hs | 8 | ||||
-rw-r--r-- | src/Xanthous/Command.hs | 5 | ||||
-rw-r--r-- | src/Xanthous/Game.hs | 12 | ||||
-rw-r--r-- | src/Xanthous/Game/Draw.hs | 8 | ||||
-rw-r--r-- | test/Xanthous/GameSpec.hs | 4 |
5 files changed, 31 insertions, 6 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index c543ad468f6d..3561d35a3bb2 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -35,7 +35,8 @@ startEvent = say ["welcome"] handleEvent :: BrickEvent Name () -> AppM (Next GameState) handleEvent (VtyEvent (EvKey k mods)) | Just command <- commandFromKey k mods - = handleCommand command + = do messageHistory %= hideMessage + handleCommand command handleEvent _ = continue handleCommand :: Command -> AppM (Next GameState) @@ -43,4 +44,7 @@ handleCommand Quit = halt handleCommand (Move dir) = do characterPosition %= move dir continue -handleCommand _ = error "unimplemented" + +handleCommand PreviousMessage = do + messageHistory %= popMessage + continue diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index 50fe4abb4561..10fa552b342f 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -8,8 +8,8 @@ import Xanthous.Data (Direction(..)) data Command = Quit | Move Direction - | PickUp | PreviousMessage + -- | PickUp commandFromKey :: Key -> [Modifier] -> Maybe Command commandFromKey (KChar 'q') [] = Just Quit @@ -17,4 +17,7 @@ commandFromKey (KChar 'h') [] = Just $ Move Left commandFromKey (KChar 'j') [] = Just $ Move Down commandFromKey (KChar 'k') [] = Just $ Move Up commandFromKey (KChar 'l') [] = Just $ Move Right + +commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage + commandFromKey _ _ = Nothing diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index 39066c23b622..dffd0a9c6a6d 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -14,6 +14,8 @@ module Xanthous.Game , MessageHistory(..) , pushMessage + , popMessage + , hideMessage ) where import Data.List.NonEmpty ( NonEmpty((:|))) @@ -43,6 +45,16 @@ pushMessage :: Text -> MessageHistory -> MessageHistory pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True +popMessage :: MessageHistory -> MessageHistory +popMessage NoMessageHistory = NoMessageHistory +popMessage (MessageHistory msgs False) = MessageHistory msgs True +popMessage (MessageHistory msgs@(_ :| []) _) = MessageHistory msgs True +popMessage (MessageHistory (_ :| (msg : msgs)) True) = MessageHistory (msg :| msgs) True + +hideMessage :: MessageHistory -> MessageHistory +hideMessage NoMessageHistory = NoMessageHistory +hideMessage (MessageHistory msgs _) = MessageHistory msgs False + data GameState = GameState { _entities :: EntityMap SomeEntity , _characterEntityID :: EntityID diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index 5a2f773c1b18..6527af743953 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -26,7 +26,13 @@ import Xanthous.Orphans () drawMessages :: MessageHistory -> Widget Name drawMessages NoMessageHistory = emptyWidget drawMessages (MessageHistory _ False) = emptyWidget -drawMessages (MessageHistory (lastMessage :| _) True) = str $ unpack lastMessage +drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage + +-- an attempt to still take up a row even when no messages +-- drawMessages msgs = vLimit 1 . Widget Greedy Fixed . render $ case msgs of +-- NoMessageHistory -> padTop (Pad 2) $ str " " +-- (MessageHistory _ False) -> padTop (Pad 2) $ str " " +-- (MessageHistory (lastMessage :| _) True) -> txt lastMessage drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name drawEntities em@(fromNullable . positions -> Just entityPositions) diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs index 1f1cc2e4d55e..9319399ac25f 100644 --- a/test/Xanthous/GameSpec.hs +++ b/test/Xanthous/GameSpec.hs @@ -15,8 +15,8 @@ test = testGroup "Xanthous.Game" [ testGroup "positionedCharacter" [ testProperty "lens laws" $ isLens positionedCharacter , testCase "updates the position of the character" $ do - let initialGame = getInitialState - initialPos = initialGame ^. characterPosition + initialGame <- getInitialState + let initialPos = initialGame ^. characterPosition updatedGame = initialGame & characterPosition %~ move Down updatedPos = updatedGame ^. characterPosition updatedPos @?= move Down initialPos |