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
2019-09-20 12:03:30 -04:00 · 2019-09-20 12:03:30 -04:00 · 7770ed0548
commit 7770ed0548
parent 62a2e05ef2
12 changed files with 312 additions and 96 deletions
--- 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 []
--- 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
-

 --------------------------------------------------------------------------------

--- 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
--- 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
--- 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)
--- a/src/Xanthous/Game/Prompt.hs
+++ 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
--- 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
+say :: (MonadRandom m, ToJSON params, MonadState GameState m)
+    => [Text] -> params -> m ()
+say msgPath params = do
+  msg <- message msgPath params
+  messageHistory %= pushMessage msg

-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_ :: Monad m => [Text] -> AppT m ()
-say_ = say
+say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m ()
+say_ msgPath = say msgPath $ object []
--- 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)
--- 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? "
--- 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) ->
--- 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
+    ]
  ]
--- 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