Display multiple messages per turn

When tracking message history, save messages associated with the turn
they were displayed on, which allows us to have the notion of the
"current turn's" messages (provided via a MonoComonad instance).

7 files changed, 84 insertions, 28 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 02f6f0987d7c..72c9a3f553ad 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -103,7 +103,7 @@ handleEvent ev = use promptState >>= \case
 handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
 handleNoPromptEvent (VtyEvent (EvKey k mods))
   | Just command <- commandFromKey k mods
-  = do messageHistory %= hideMessage
+  = do messageHistory %= nextTurn
        handleCommand command
 handleNoPromptEvent _ = continue
 
@@ -135,7 +135,7 @@ handleCommand PickUp = do
   continue
 
 handleCommand PreviousMessage = do
-  messageHistory %= popMessage
+  messageHistory %= previousMessage
   continue
 
 handleCommand Open = do
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 2b346ace5631..0ab5425a04f4 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -14,10 +14,14 @@ module Xanthous.Game
   , characterPosition
   , updateCharacterVision
 
+    -- * Messages
   , MessageHistory(..)
+  , HasMessages(..)
+  , HasTurn(..)
+  , HasDisplayedTurn(..)
   , pushMessage
-  , popMessage
-  , hideMessage
+  , previousMessage
+  , nextTurn
 
     -- * Collisions
   , Collision(..)
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index e1242f2b7a2d..addeaa14cd45 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -8,7 +8,6 @@ import           Brick hiding (loc)
 import           Brick.Widgets.Border
 import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Edit
-import           Data.List.NonEmpty(NonEmpty((:|)))
 --------------------------------------------------------------------------------
 import           Xanthous.Data (Position(Position), x, y, loc)
 import           Xanthous.Data.EntityMap (EntityMap, atPosition)
@@ -34,9 +33,7 @@ import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
 
 drawMessages :: MessageHistory -> Widget Name
-drawMessages NoMessageHistory = emptyWidget
-drawMessages (MessageHistory _ False) = str " "
-drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
+drawMessages = txt . (<> " ") . unwords . oextract
 
 drawPromptState :: GamePromptState m -> Widget Name
 drawPromptState NoPrompt = emptyWidget
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index e077e339cd87..101de3021c48 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -36,7 +36,7 @@ getInitialState = do
           (Position 0 0)
           (SomeEntity char)
           mempty
-      _messageHistory = NoMessageHistory
+      _messageHistory = mempty
       _revealedPositions = mempty
       _promptState = NoPrompt
       _debugState = DebugState
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 00785bf12440..302d20e1efdc 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -14,9 +14,12 @@ module Xanthous.Game.State
 
     -- * Messages
   , MessageHistory(..)
+  , HasMessages(..)
+  , HasTurn(..)
+  , HasDisplayedTurn(..)
   , pushMessage
-  , popMessage
-  , hideMessage
+  , previousMessage
+  , nextTurn
 
     -- * App monad
   , AppT(..)
@@ -61,27 +64,54 @@ import           Xanthous.Resource
 --------------------------------------------------------------------------------
 
 data MessageHistory
-  = NoMessageHistory
-  | MessageHistory (NonEmpty Text) Bool
+  = MessageHistory
+  { _messages      :: Map Word (NonEmpty Text)
+  , _turn          :: Word
+  , _displayedTurn :: Maybe Word
+  }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+makeFieldsNoPrefix ''MessageHistory
+
+instance Semigroup MessageHistory where
+  (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) =
+    MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of
+      (_, Nothing)      -> Nothing
+      (Just t, _)       -> Just t
+      (Nothing, Just t) -> Just t
+
+instance Monoid MessageHistory where
+  mempty = MessageHistory mempty 0 Nothing
 
 instance Arbitrary MessageHistory where
   arbitrary = genericArbitrary
 
+type instance Element MessageHistory = [Text]
+instance MonoFunctor MessageHistory where
+  omap f mh@(MessageHistory _ t _) =
+    mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<)
+
+instance MonoComonad MessageHistory where
+  oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt)
+  oextend cok mh@(MessageHistory _ t dt) =
+    mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh)
+
 pushMessage :: Text -> MessageHistory -> MessageHistory
-pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
-pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
+pushMessage msg mh@(MessageHistory _ turn' _) =
+  mh
+  & messages . at turn' %~ \case
+    Nothing -> Just $ msg :| mempty
+    Just msgs -> Just $ msg <| msgs
+  & displayedTurn .~ Nothing
+
+nextTurn :: MessageHistory -> MessageHistory
+nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
 
-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
+previousMessage :: MessageHistory -> MessageHistory
+previousMessage mh = mh & displayedTurn .~ maximumOf
+  (messages . ifolded . asIndex . filtered (< mh ^. turn))
+  mh
 
-hideMessage :: MessageHistory -> MessageHistory
-hideMessage NoMessageHistory = NoMessageHistory
-hideMessage (MessageHistory msgs _) = MessageHistory msgs False
 
 --------------------------------------------------------------------------------
 
@@ -152,7 +182,7 @@ instance Eq SomeEntity where
     Just Refl -> a == b
     _ -> False
 
-instance Draw (SomeEntity) where
+instance Draw SomeEntity where
   drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
 
 instance Brain SomeEntity where
diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs
index 22325f636637..610067a375e2 100644
--- a/src/Xanthous/Orphans.hs
+++ b/src/Xanthous/Orphans.hs
@@ -25,7 +25,8 @@ import           Text.Mustache.Type ( showKey )
 
 instance forall s a.
   ( Cons s s a a
-  , MonoFoldable s
+  , IsSequence s
+  , Element s ~ a
   ) => Cons (NonNull s) (NonNull s) a a where
   _Cons = prism hither yon
     where
@@ -35,9 +36,21 @@ instance forall s a.
         in impureNonNull $ a <| s
 
       yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
-      yon ns = case ns ^? _Cons of
-        Nothing -> Left ns
-        Just (a, ns') -> Right (a, ns')
+      yon ns = case nuncons ns of
+        (_, Nothing) -> Left ns
+        (x, Just xs) -> Right (x, xs)
+
+instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where
+  _Cons = prism hither yon
+    where
+      hither :: (a, NonEmpty a) -> NonEmpty a
+      hither (a, x :| xs) = a :| (x : xs)
+
+      yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a)
+      yon ns@(x :| xs) = case xs of
+        (y : ys) -> Right (x, y :| ys)
+        [] -> Left ns
+
 
 instance Arbitrary PName where
   arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs
index 32faae03d7a9..af98c7f6ccd2 100644
--- a/test/Xanthous/GameSpec.hs
+++ b/test/Xanthous/GameSpec.hs
@@ -30,4 +30,16 @@ test = testGroup "Xanthous.Game"
   , testGroup "character"
     [ testProperty "lens laws" $ isLens character
     ]
+  , localOption (QuickCheckTests 10)
+  $ testGroup "MessageHistory"
+    [ testGroup "MonoComonad laws"
+      [ testProperty "oextend oextract ≡ id"
+        $ \(mh :: MessageHistory) -> oextend oextract mh === mh
+      , testProperty "oextract ∘ oextend f ≡ f"
+        $ \(mh :: MessageHistory) f -> (oextract . oextend f) mh === f mh
+      , testProperty "oextend f ∘ oextend g ≡ oextend (f . oextend g)"
+        $ \(mh :: MessageHistory) f g ->
+          (oextend f . oextend g) mh === oextend (f . oextend g) mh
+      ]
+    ]
   ]