Link up messages to the overall game

Add a "say" function for saying messages within an app monad to the
user, and link everything up to display them and track their history

7 files changed, 151 insertions, 37 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index ae88a746cec6..c543ad468f6d 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -1,35 +1,46 @@
 module Xanthous.App (makeApp) where
 
 import Xanthous.Prelude
-import Brick hiding (App)
+import Brick hiding (App, halt, continue)
 import qualified Brick
 import Graphics.Vty.Attributes (defAttr)
 import Graphics.Vty.Input.Events (Event(EvKey))
+import Control.Monad.State (get)
 
 import Xanthous.Game
 import Xanthous.Game.Draw (drawGame)
 import Xanthous.Resource (Name)
 import Xanthous.Command
 import Xanthous.Data (move)
+import Xanthous.Monad
 
 type App = Brick.App GameState () Name
+type AppM a = AppT (EventM Name) a
 
 makeApp :: IO App
 makeApp = pure $ Brick.App
   { appDraw = drawGame
   , appChooseCursor = const headMay
-  , appHandleEvent = handleEvent
-  , appStartEvent = pure
+  , appHandleEvent = \state event -> runAppM (handleEvent event) state
+  , appStartEvent = runAppM $ startEvent >> get
   , appAttrMap = const $ attrMap defAttr []
   }
 
-handleEvent :: GameState -> BrickEvent Name () -> EventM Name (Next GameState)
-handleEvent game (VtyEvent (EvKey k mods))
+runAppM :: AppM a -> GameState -> EventM Name a
+runAppM appm = fmap fst . runAppT appm
+
+startEvent :: AppM ()
+startEvent = say ["welcome"]
+
+handleEvent :: BrickEvent Name () -> AppM (Next GameState)
+handleEvent (VtyEvent (EvKey k mods))
   | Just command <- commandFromKey k mods
-  = handleCommand command game
-handleEvent game _ = continue game
+  = handleCommand command
+handleEvent _ = continue
 
-handleCommand :: Command -> GameState -> EventM Name (Next GameState)
+handleCommand :: Command -> AppM (Next GameState)
 handleCommand Quit = halt
-handleCommand (Move dir) = continue . (characterPosition %~ move dir)
+handleCommand (Move dir) = do
+  characterPosition %= move dir
+  continue
 handleCommand _ = error "unimplemented"
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index f30f7534392f..39066c23b622 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -3,46 +3,82 @@
 module Xanthous.Game
   ( GameState(..)
   , entities
+  , messageHistory
+  , randomGen
+
   , getInitialState
 
   , positionedCharacter
   , character
   , characterPosition
+
+  , MessageHistory(..)
+  , pushMessage
   ) where
 
-import Xanthous.Prelude
-import Test.QuickCheck.Arbitrary
+import           Data.List.NonEmpty ( NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
+import           System.Random
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+import           Xanthous.Prelude
 
-import Xanthous.Data.EntityMap (EntityMap, EntityID)
+import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import qualified Xanthous.Data.EntityMap as EntityMap
-import Xanthous.Data (Positioned, Position(..), positioned, position)
-import Xanthous.Entities.SomeEntity
-import Xanthous.Entities.Character
+import           Xanthous.Data (Positioned, Position(..), positioned, position)
+import           Xanthous.Entities.SomeEntity
+import           Xanthous.Entities.Character
+import           Xanthous.Orphans ()
+
+data MessageHistory
+  = NoMessageHistory
+  | MessageHistory (NonEmpty Text) Bool
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary MessageHistory where
+  arbitrary = genericArbitrary
+
+pushMessage :: Text -> MessageHistory -> MessageHistory
+pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
+pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
 
 data GameState = GameState
   { _entities          :: EntityMap SomeEntity
   , _characterEntityID :: EntityID
+  , _messageHistory    :: MessageHistory
+  , _randomGen         :: StdGen
   }
-  deriving stock (Show, Eq)
+  deriving stock (Show)
 makeLenses ''GameState
 
+instance Eq GameState where
+  (GameState es₁ ceid₁ mh₁ _) == (GameState es₂ ceid₂ mh₂ _)
+    = es₁ == es₂
+    && ceid₁ == ceid₂
+    && mh₁ == mh₂
+
 instance Arbitrary GameState where
   arbitrary = do
-    ents <- arbitrary
-    char <- arbitrary
-    pure $ getInitialState
-      & entities .~ ents
-      & positionedCharacter .~ char
-
-getInitialState :: GameState
-getInitialState =
+    char <- arbitrary @Character
+    charPos <- arbitrary
+    _messageHistory <- arbitrary
+    (_characterEntityID, _entities) <- arbitrary <&>
+      EntityMap.insertAtReturningID charPos (SomeEntity char)
+    _randomGen <- mkStdGen <$> arbitrary
+    pure $ GameState {..}
+
+getInitialState :: IO GameState
+getInitialState = do
+  _randomGen <- getStdGen
   let char = mkCharacter
       (_characterEntityID, _entities)
         = EntityMap.insertAtReturningID
           (Position 0 0)
           (SomeEntity char)
           mempty
-  in GameState {..}
+      _messageHistory = NoMessageHistory
+  pure GameState {..}
 
 positionedCharacter :: Lens' GameState (Positioned Character)
 positionedCharacter = lens getPositionedCharacter setPositionedCharacter
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 79089029ea8d..5a2f773c1b18 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -8,15 +8,25 @@ import Xanthous.Prelude
 import Brick hiding (loc)
 import Brick.Widgets.Border
 import Brick.Widgets.Border.Style
+import Data.List.NonEmpty(NonEmpty((:|)))
 
 import Xanthous.Data (Position(Position), x, y, loc)
 import Xanthous.Data.EntityMap
 import Xanthous.Entities
-import Xanthous.Game (GameState(..), entities, characterPosition)
+import Xanthous.Game
+  ( GameState(..)
+  , entities
+  , characterPosition
+  , MessageHistory(..)
+  , messageHistory
+  )
 import Xanthous.Resource (Name(..))
+import Xanthous.Orphans ()
 
-drawMessages :: GameState -> Widget Name
-drawMessages _ = str "Welcome to Xanthous! It's dangerous out there, why not stay inside?"
+drawMessages :: MessageHistory -> Widget Name
+drawMessages NoMessageHistory = emptyWidget
+drawMessages (MessageHistory _ False) = emptyWidget
+drawMessages (MessageHistory (lastMessage :| _) True) = str $ unpack lastMessage
 
 drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name
 drawEntities em@(fromNullable . positions -> Just entityPositions)
@@ -41,5 +51,5 @@ drawGame :: GameState -> [Widget Name]
 drawGame game
   = pure
   . withBorderStyle unicode
-  $   drawMessages game
+  $   drawMessages (game ^. messageHistory)
   <=> border (drawMap game)
diff --git a/src/Xanthous/Messages.hs b/src/Xanthous/Messages.hs
index 4ff46ba3f5e7..b1aeeb635cc9 100644
--- a/src/Xanthous/Messages.hs
+++ b/src/Xanthous/Messages.hs
@@ -9,19 +9,19 @@ module Xanthous.Messages
   , messages
   , message
   ) where
-
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
+
+import Control.Monad.Random.Class (MonadRandom)
+import Data.Aeson (FromJSON, ToJSON, toJSON)
+import Data.Aeson.Generic.DerivingVia
+import Data.FileEmbed
 import Data.List.NonEmpty
 import Test.QuickCheck hiding (choose)
 import Test.QuickCheck.Arbitrary.Generic
 import Test.QuickCheck.Instances.UnorderedContainers ()
 import Text.Mustache
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Aeson.Generic.DerivingVia
-import Data.FileEmbed
 import qualified Data.Yaml as Yaml
-import Data.Aeson (toJSON)
-import Control.Monad.Random.Class (MonadRandom)
 
 import Xanthous.Random
 import Xanthous.Orphans ()
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
new file mode 100644
index 000000000000..fb790d5f9cb2
--- /dev/null
+++ b/src/Xanthous/Monad.hs
@@ -0,0 +1,58 @@
+module Xanthous.Monad
+  ( AppT(..)
+  , runAppT
+  , continue
+  , halt
+  , say
+  ) where
+
+import Xanthous.Prelude
+import Control.Monad.Random
+import Control.Monad.State
+import qualified Brick
+import Brick (EventM, Next)
+import Data.Aeson
+
+import Xanthous.Game
+import Xanthous.Messages (message)
+
+newtype AppT m a
+  = AppT { unAppT :: StateT GameState m a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadState GameState
+           )
+       via (StateT GameState m)
+
+instance MonadTrans AppT where
+  lift = AppT . lift
+
+instance (Monad m) => MonadRandom (AppT m) where
+  getRandomR rng = randomGen %%= randomR rng
+  getRandom = randomGen %%= random
+  getRandomRs rng = uses randomGen $ randomRs rng
+  getRandoms = uses randomGen randoms
+
+runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState)
+runAppT appt initialState = flip runStateT initialState . unAppT $ appt
+
+halt :: AppT (EventM n) (Next GameState)
+halt = lift . Brick.halt =<< get
+
+continue :: AppT (EventM n) (Next GameState)
+continue = lift . Brick.continue =<< get
+
+-- say :: [Text] -> AppT m ()
+-- say :: [Text] -> params -> AppT m ()
+
+class SayR a where
+  say :: [Text] -> a
+
+instance Monad m => SayR (AppT m ()) where
+  say msgPath = say msgPath $ object []
+
+instance (Monad m, ToJSON params) => SayR (params -> AppT m ()) where
+  say msgPath params = do
+    msg <- message msgPath params
+    messageHistory %= pushMessage msg
diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs
index 20970809754b..756642440b7e 100644
--- a/src/Xanthous/Prelude.hs
+++ b/src/Xanthous/Prelude.hs
@@ -8,7 +8,7 @@ module Xanthous.Prelude
   ) where
 
 import ClassyPrelude hiding
-  (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index)
+  (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say)
 import Data.Kind
 import GHC.TypeLits hiding (Text)
 import Control.Lens
diff --git a/src/Xanthous/Random.hs b/src/Xanthous/Random.hs
index a3a1124f2780..33ada54cf105 100644
--- a/src/Xanthous/Random.hs
+++ b/src/Xanthous/Random.hs
@@ -8,7 +8,6 @@ module Xanthous.Random
 
 import Xanthous.Prelude
 import Data.List.NonEmpty (NonEmpty)
-import System.Random
 import Control.Monad.Random.Class (MonadRandom(getRandomR))
 
 class Choose a where