Add the beginnings of a prompt system

Add the beginnings of a generic prompt system, with exclusive support
atm for string prompts, and test it out by asking the character for
their name at startup

12 files changed, 312 insertions, 96 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 0f49b4d8007c..0c7b85541ae0 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -4,11 +4,13 @@ module Xanthous.App (makeApp) where
 import           Xanthous.Prelude
 import           Brick hiding (App, halt, continue, raw)
 import qualified Brick
+import           Brick.Widgets.Edit (handleEditorEvent)
 import           Graphics.Vty.Attributes (defAttr)
-import           Graphics.Vty.Input.Events (Event(EvKey))
-import           Control.Monad.State (get)
+import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
+import           Control.Monad.State (get, state, StateT(..))
+import           Data.Coerce
 import           Control.Monad.State.Class (modify)
-import           Data.Aeson (object)
+import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
 --------------------------------------------------------------------------------
 import           Xanthous.Command
@@ -20,14 +22,13 @@ import           Xanthous.Data
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game
 import           Xanthous.Game.Draw (drawGame)
+import           Xanthous.Game.Prompt
 import           Xanthous.Monad
 import           Xanthous.Resource (Name)
+import           Xanthous.Messages (message)
 --------------------------------------------------------------------------------
-import           Xanthous.Entities.Creature (Creature)
-import qualified Xanthous.Entities.Creature as Creature
 import qualified Xanthous.Entities.Character as Character
-import           Xanthous.Entities.RawTypes (EntityRaw(..))
-import           Xanthous.Entities.Raws (raw)
+import           Xanthous.Entities.Character (characterName)
 import           Xanthous.Entities
 import           Xanthous.Entities.Item (Item)
 import           Xanthous.Generators
@@ -41,7 +42,7 @@ makeApp :: IO App
 makeApp = pure $ Brick.App
   { appDraw = drawGame
   , appChooseCursor = const headMay
-  , appHandleEvent = \state event -> runAppM (handleEvent event) state
+  , appHandleEvent = \game event -> runAppM (handleEvent event) game
   , appStartEvent = runAppM $ startEvent >> get
   , appAttrMap = const $ attrMap defAttr []
   }
@@ -49,14 +50,13 @@ makeApp = pure $ Brick.App
 runAppM :: AppM a -> GameState -> EventM Name a
 runAppM appm = fmap fst . runAppT appm
 
-testGormlak :: Creature
-testGormlak =
-  let Just (Creature gormlak) = raw "gormlak"
-  in Creature.newWithType gormlak
+-- testGormlak :: Creature
+-- testGormlak =
+--   let Just (Creature gormlak) = raw "gormlak"
+--   in Creature.newWithType gormlak
 
 startEvent :: AppM ()
 startEvent = do
-  say_ ["welcome"]
   level <-
     generateLevel SCaveAutomata CaveAutomata.defaultParams
     $ Dimensions 80 80
@@ -64,15 +64,23 @@ startEvent = do
   entities <>= (SomeEntity <$> level ^. levelItems)
   characterPosition .= level ^. levelCharacterPosition
   modify updateCharacterVision
-  -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
-
+  prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable
+    $ \(StringResult s) -> do
+      character . characterName ?= s
+      say ["welcome"] =<< use character
 
 handleEvent :: BrickEvent Name () -> AppM (Next GameState)
-handleEvent (VtyEvent (EvKey k mods))
+handleEvent ev = use promptState >>= \case
+  NoPrompt -> handleNoPromptEvent ev
+  WaitingPrompt msg pr -> handlePromptEvent msg pr ev
+
+
+handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
+handleNoPromptEvent (VtyEvent (EvKey k mods))
   | Just command <- commandFromKey k mods
   = do messageHistory %= hideMessage
        handleCommand command
-handleEvent _ = continue
+handleNoPromptEvent _ = continue
 
 handleCommand :: Command -> AppM (Next GameState)
 handleCommand Quit = halt
@@ -106,3 +114,48 @@ handleCommand PreviousMessage = do
   messageHistory %= popMessage
   continue
 
+handlePromptEvent
+  :: Text -- ^ Prompt message
+  -> Prompt (AppT Identity)
+  -> BrickEvent Name ()
+  -> AppM (Next GameState)
+handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do
+  promptState .= NoPrompt
+  continue
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do
+  () <- state . coerce $ submitPrompt pr
+  promptState .= NoPrompt
+  continue
+handlePromptEvent
+  msg
+  (Prompt c SStringPrompt (StringPromptState edit) cb)
+  (VtyEvent ev)
+  = do
+    edit' <- lift $ handleEditorEvent ev edit
+    let prompt' = Prompt c SStringPrompt (StringPromptState edit') cb
+    promptState .= WaitingPrompt msg prompt'
+    continue
+handlePromptEvent _ _ _ = undefined
+
+prompt
+  :: forall (pt :: PromptType) (params :: Type).
+    (ToJSON params, SingPromptType pt)
+  => [Text]                     -- ^ Message key
+  -> params                     -- ^ Message params
+  -> PromptCancellable
+  -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt msgPath params cancellable cb = do
+  let pt = singPromptType @pt
+  msg <- message msgPath params
+  let p = mkPrompt cancellable pt cb
+  promptState .= WaitingPrompt msg p
+
+prompt_
+  :: forall (pt :: PromptType) .
+    (SingPromptType pt)
+  => [Text] -- ^ Message key
+  -> PromptCancellable
+  -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt_ msg = prompt msg $ object []
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
index 926a02a48ce1..7885839d51b0 100644
--- a/src/Xanthous/Data/EntityMap.hs
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -23,7 +23,10 @@ module Xanthous.Data.EntityMap
   , neighbors
   , Deduplicate(..)
 
-    -- * Querying an entityMap
+  -- * debug
+  , byID
+  , byPosition
+
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude hiding (lookup)
@@ -31,7 +34,6 @@ import Xanthous.Data
   ( Position
   , Positioned(..)
   , positioned
-  , position
   , Neighbors(..)
   , neighborPositions
   )
@@ -81,15 +83,15 @@ instance At (EntityMap a) where
         pure $ m
           & removeEIDAtPos pos
           & byID . at eid .~ Nothing
-      setter m (Just (Positioned pos e)) =
-        case lookupWithPosition eid m of
-          Nothing -> insertAt pos e m
-          Just (Positioned origPos _) -> m
-            & removeEIDAtPos origPos
-            & byID . ix eid . position .~ pos
-            & byPosition . at pos %~ \case
-              Nothing -> Just $ ncons eid mempty
-              Just es -> Just $ eid <| es
+      setter m (Just pe@(Positioned pos _)) = m
+        & (case lookupWithPosition eid m of
+             Nothing -> id
+             Just (Positioned origPos _) -> removeEIDAtPos origPos
+          )
+        & byID . at eid ?~ pe
+        & byPosition . at pos %~ \case
+            Nothing -> Just $ ncons eid mempty
+            Just es -> Just $ eid <| es
       removeEIDAtPos pos =
         byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid))
 
@@ -117,9 +119,6 @@ instance Semigroup (Deduplicate a) where
         _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
     in Deduplicate EntityMap{..}
 
-instance Monoid (Deduplicate a) where
-  mempty = Deduplicate emptyEntityMap
-
 
 --------------------------------------------------------------------------------
 
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 3b2b320004e2..695d7bb0d0d1 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Xanthous.Entities.Character
   ( Character(..)
+  , characterName
+  , inventory
   , mkCharacter
   , pickUpItem
   ) where
@@ -10,6 +12,8 @@ import Test.QuickCheck
 import Test.QuickCheck.Instances.Vector ()
 import Test.QuickCheck.Arbitrary.Generic
 import Brick
+import Data.Aeson.Generic.DerivingVia
+import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Entities
 import Xanthous.Entities.Item
@@ -17,9 +21,13 @@ import Xanthous.Entities.Item
 
 data Character = Character
   { _inventory :: !(Vector Item)
+  , _characterName :: !(Maybe Text)
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Character
 makeLenses ''Character
 
 scrollOffset :: Int
@@ -40,6 +48,7 @@ instance Arbitrary Character where
 mkCharacter :: Character
 mkCharacter = Character
   { _inventory = mempty
+  , _characterName = Nothing
   }
 
 pickUpItem :: Item -> Character -> Character
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 777e05ee4149..59e436edc942 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -8,6 +8,8 @@ module Xanthous.Game
   , revealedPositions
   , messageHistory
   , randomGen
+  , promptState
+  , GamePromptState(..)
 
   , getInitialState
 
@@ -24,6 +26,9 @@ module Xanthous.Game
     -- * collisions
   , Collision(..)
   , collisionAt
+
+    -- * App monad
+  , AppT(..)
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -34,6 +39,8 @@ import           System.Random
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
 import           Control.Monad.State.Class
+import           Control.Monad.State
+import           Control.Monad.Random.Class
 --------------------------------------------------------------------------------
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import qualified Xanthous.Data.EntityMap as EntityMap
@@ -45,6 +52,7 @@ import           Xanthous.Entities.Creature
 import           Xanthous.Entities.Item
 import           Xanthous.Entities.Arbitrary ()
 import           Xanthous.Orphans ()
+import           Xanthous.Game.Prompt
 --------------------------------------------------------------------------------
 
 data MessageHistory
@@ -70,12 +78,33 @@ hideMessage :: MessageHistory -> MessageHistory
 hideMessage NoMessageHistory = NoMessageHistory
 hideMessage (MessageHistory msgs _) = MessageHistory msgs False
 
+--------------------------------------------------------------------------------
+
+data GamePromptState m where
+  NoPrompt :: GamePromptState m
+  WaitingPrompt :: Text -> Prompt m -> GamePromptState m
+  deriving stock (Show)
+
+--------------------------------------------------------------------------------
+
+newtype AppT m a
+  = AppT { unAppT :: StateT GameState m a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadState GameState
+           )
+       via (StateT GameState m)
+
+--------------------------------------------------------------------------------
+
 data GameState = GameState
   { _entities          :: !(EntityMap SomeEntity)
   , _revealedPositions :: !(Set Position)
   , _characterEntityID :: !EntityID
   , _messageHistory    :: !MessageHistory
   , _randomGen         :: !StdGen
+  , _promptState       :: !(GamePromptState (AppT Identity))
   }
   deriving stock (Show)
 makeLenses ''GameState
@@ -88,6 +117,7 @@ instance Eq GameState where
     , gs ^. messageHistory
     )
 
+
 instance Arbitrary GameState where
   arbitrary = do
     char <- arbitrary @Character
@@ -97,8 +127,10 @@ instance Arbitrary GameState where
       EntityMap.insertAtReturningID charPos (SomeEntity char)
     _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
     _randomGen <- mkStdGen <$> arbitrary
+    let _promptState = NoPrompt -- TODO
     pure $ GameState {..}
 
+
 getInitialState :: IO GameState
 getInitialState = do
   _randomGen <- getStdGen
@@ -110,6 +142,7 @@ getInitialState = do
           mempty
       _messageHistory = NoMessageHistory
       _revealedPositions = mempty
+      _promptState = NoPrompt
   pure GameState {..}
 
 positionedCharacter :: Lens' GameState (Positioned Character)
@@ -166,3 +199,14 @@ collisionAt pos = do
        | any (entityIs @Creature) ents -> pure Combat
        | all (entityIs @Item) ents -> Nothing
        | otherwise -> pure Stop
+
+--------------------------------------------------------------------------------
+
+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
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 8deb20ff84cb..60ae7110a6bf 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -1,40 +1,47 @@
-{-# LANGUAGE ViewPatterns #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Game.Draw
   ( drawGame
   ) where
-
-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 (EntityMap, atPosition)
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+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)
 import qualified Xanthous.Data.EntityMap as EntityMap
-import Xanthous.Entities
-import Xanthous.Game
-  ( GameState(..)
-  , entities
-  , revealedPositions
-  , characterPosition
-  , MessageHistory(..)
-  , messageHistory
-  )
-import Xanthous.Resource (Name(..))
-import Xanthous.Orphans ()
+import           Xanthous.Entities
+import           Xanthous.Game
+                 ( GameState(..)
+                 , entities
+                 , revealedPositions
+                 , characterPosition
+                 , MessageHistory(..)
+                 , messageHistory
+                 , GamePromptState(..)
+                 , promptState
+                 )
+import           Xanthous.Game.Prompt
+import           Xanthous.Resource (Name)
+import qualified Xanthous.Resource as Resource
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
 
 drawMessages :: MessageHistory -> Widget Name
 drawMessages NoMessageHistory = emptyWidget
-drawMessages (MessageHistory _ False) = emptyWidget
+drawMessages (MessageHistory _ False) = str " "
 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
+drawPromptState :: GamePromptState m -> Widget Name
+drawPromptState NoPrompt = emptyWidget
+drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      txt msg <+> renderEditor (txt . fold) True edit
+    _ -> undefined
 
 drawEntities
   :: Set Position
@@ -61,8 +68,8 @@ drawEntities visiblePositions allEnts
 
 drawMap :: GameState -> Widget Name
 drawMap game
-  = viewport MapViewport Both
-  . showCursor Character (game ^. characterPosition . loc)
+  = viewport Resource.MapViewport Both
+  . showCursor Resource.Character (game ^. characterPosition . loc)
   $ drawEntities
     (game ^. revealedPositions)
     (game ^. entities)
@@ -72,4 +79,5 @@ drawGame game
   = pure
   . withBorderStyle unicode
   $   drawMessages (game ^. messageHistory)
+  <=> drawPromptState (game ^. promptState)
   <=> border (drawMap game)
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 000000000000..928340f06480
--- /dev/null
+++ b/src/Xanthous/Game/Prompt.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Prompt
+  ( PromptType(..)
+  , SPromptType(..)
+  , SingPromptType(..)
+  , PromptCancellable(..)
+  , PromptResult(..)
+  , PromptState(..)
+  , Prompt(..)
+  , mkPrompt
+  , isCancellable
+  , submitPrompt
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.Widgets.Edit (Editor, editorText, getEditContents)
+import Test.QuickCheck
+import Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import Xanthous.Data (Direction, Position)
+import Xanthous.Resource (Name)
+import qualified Xanthous.Resource as Resource
+--------------------------------------------------------------------------------
+
+data PromptType where
+  StringPrompt    :: PromptType
+  Confirm         :: PromptType
+  Menu            :: Type -> PromptType
+  DirectionPrompt :: PromptType
+  PointOnMap      :: PromptType
+  deriving stock (Generic)
+
+instance Show PromptType where
+  show StringPrompt = "StringPrompt"
+  show Confirm = "Confirm"
+  show (Menu _) = "Menu"
+  show DirectionPrompt = "DirectionPrompt"
+  show PointOnMap = "PointOnMap"
+
+data SPromptType :: PromptType -> Type where
+  SStringPrompt    ::      SPromptType 'StringPrompt
+  SConfirm         ::      SPromptType 'Confirm
+  SMenu            :: forall a. SPromptType ('Menu a)
+  SDirectionPrompt ::      SPromptType 'DirectionPrompt
+  SPointOnMap      ::      SPromptType 'PointOnMap
+
+class SingPromptType pt where singPromptType :: SPromptType pt
+instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
+
+instance Show (SPromptType pt) where
+  show SStringPrompt    = "SStringPrompt"
+  show SConfirm         = "SConfirm"
+  show SMenu            = "SMenu"
+  show SDirectionPrompt = "SDirectionPrompt"
+  show SPointOnMap      = "SPointOnMap"
+
+data PromptCancellable
+  = Cancellable
+  | Uncancellable
+  deriving stock (Show, Eq, Ord, Enum, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary PromptCancellable where
+  arbitrary = genericArbitrary
+
+data PromptResult (pt :: PromptType) where
+  StringResult     :: Text      -> PromptResult 'StringPrompt
+  ConfirmResult    :: Bool      -> PromptResult 'Confirm
+  MenuResult       :: forall a. a    -> PromptResult ('Menu a)
+  DirectionResult  :: Direction -> PromptResult 'DirectionPrompt
+  PointOnMapResult :: Position  -> PromptResult 'PointOnMap
+
+data PromptState pt where
+  StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
+
+deriving stock instance Show (PromptState pt)
+
+data Prompt (m :: Type -> Type) where
+  Prompt
+    :: forall (pt :: PromptType)
+        (m :: Type -> Type).
+      PromptCancellable
+    -> SPromptType pt
+    -> PromptState pt
+    -> (PromptResult pt -> m ())
+    -> Prompt m
+
+instance Show (Prompt m) where
+  show (Prompt c pt ps _)
+    = "(Prompt "
+    <> show c <> " "
+    <> show pt <> " "
+    <> show ps
+    <> " <function> )"
+
+mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
+mkPrompt c pt@SStringPrompt cb =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c pt ps cb
+mkPrompt _ _ _ = undefined
+
+isCancellable :: Prompt m -> Bool
+isCancellable (Prompt Cancellable _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _) = False
+
+submitPrompt :: Prompt m -> m ()
+submitPrompt (Prompt _ pt ps cb) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      cb . StringResult . mconcat . getEditContents $ edit
+    _ -> undefined
+
+-- data PromptInput :: PromptType -> Type where
+--   StringInput :: PromptInput 'StringPrompt
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
index acf7775ede41..4e3e58607ce8 100644
--- a/src/Xanthous/Monad.hs
+++ b/src/Xanthous/Monad.hs
@@ -17,24 +17,6 @@ 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
 
@@ -44,19 +26,12 @@ 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
+say :: (MonadRandom m, ToJSON params, MonadState GameState m)
+    => [Text] -> params -> m ()
+say msgPath params = do
+  msg <- message msgPath params
+  messageHistory %= pushMessage msg
 
-say_ :: Monad m => [Text] -> AppT m ()
-say_ = say
+say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m ()
+say_ msgPath = say msgPath $ object []
diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs
index aa9020903cfc..782fd5040d93 100644
--- a/src/Xanthous/Resource.hs
+++ b/src/Xanthous/Resource.hs
@@ -10,4 +10,5 @@ data Name = MapViewport
             -- ^ The character
           | MessageBox
             -- ^ The box where we display messages to the user
+          | Prompt
   deriving stock (Show, Eq, Ord)
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 5bb11ab05945..0f0a0149f6d0 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -1,4 +1,6 @@
-welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?
+welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
 items:
   pickUp: You pick up the {{item.itemType.name}}
   nothingToPickUp: There's nothing here to pick up
+character:
+  namePrompt: "What's your name? "
diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs
index 00bf1500466a..2e9714a44eb7 100644
--- a/test/Xanthous/Data/EntityMapSpec.hs
+++ b/test/Xanthous/Data/EntityMapSpec.hs
@@ -15,7 +15,10 @@ test = localOption (QuickCheckTests 20)
   $ testGroup "Xanthous.Data.EntityMap"
   [ testBatch $ monoid @(EntityMap Int) mempty
   , testGroup "Deduplicate"
-    [ testBatch $ monoid @(Deduplicate Int) mempty
+    [ testGroup "Semigroup laws"
+      [ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c ->
+          a <> (b <> c) === (a <> b) <> c
+      ]
     ]
   , testGroup "Eq laws"
     [ testProperty "reflexivity" $ \(em :: EntityMap Int) ->
diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs
index dbd1677f7e79..32faae03d7a9 100644
--- a/test/Xanthous/GameSpec.hs
+++ b/test/Xanthous/GameSpec.hs
@@ -27,4 +27,7 @@ test = testGroup "Xanthous.Game"
   , testGroup "characterPosition"
     [ testProperty "lens laws" $ isLens characterPosition
     ]
+  , testGroup "character"
+    [ testProperty "lens laws" $ isLens character
+    ]
   ]
diff --git a/xanthous.cabal b/xanthous.cabal
index ef3498af060c..cb89323b2b08 100644
--- a/xanthous.cabal
+++ b/xanthous.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 78a45f3d5eb8c2993c219fd4214f61e9842177fa4d97667aeaedbfe3d0842165
+-- hash: 40187d0301465905043b8caafec5465e644f711620c9fc1cfc57af4105ebe08c
 
 name:           xanthous
 version:        0.1.0.0
@@ -46,6 +46,7 @@ library
       Xanthous.Entities.RawTypes
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Game.Prompt
       Xanthous.Generators
       Xanthous.Generators.CaveAutomata
       Xanthous.Generators.LevelContents
@@ -118,6 +119,7 @@ executable xanthous
       Xanthous.Entities.RawTypes
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Game.Prompt
       Xanthous.Generators
       Xanthous.Generators.CaveAutomata
       Xanthous.Generators.LevelContents