Add entities, and allow walking around

Add support for entities via a port of the EntityMap type, and implement
command support starting at basic hjkl.

13 files changed, 546 insertions, 14 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 5c0383c38e19..bf5ec68abb0d 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -4,10 +4,13 @@ import Xanthous.Prelude
 import Brick hiding (App)
 import qualified Brick
 import Graphics.Vty.Attributes (defAttr)
+import Graphics.Vty.Input.Events (Event(EvResize, EvKey))
 
 import Xanthous.Game
 import Xanthous.Game.Draw (drawGame)
 import Xanthous.Resource (Name)
+import Xanthous.Command
+import Xanthous.Data (move)
 
 type App = Brick.App GameState () Name
 
@@ -15,7 +18,18 @@ makeApp :: IO App
 makeApp = pure $ Brick.App
   { appDraw = drawGame
   , appChooseCursor = const headMay
-  , appHandleEvent = resizeOrQuit
+  , appHandleEvent = handleEvent
   , appStartEvent = pure
   , appAttrMap = const $ attrMap defAttr []
   }
+
+handleEvent :: GameState -> BrickEvent Name () -> EventM Name (Next GameState)
+handleEvent game (VtyEvent (EvKey k mods))
+  | Just command <- commandFromKey k mods
+  = handleCommand command game
+handleEvent game _ = continue game
+
+handleCommand :: Command -> GameState -> EventM Name (Next GameState)
+handleCommand Quit = halt
+handleCommand (Move dir) = continue . (characterPosition %~ move dir)
+handleCommand _ = undefined
diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs
new file mode 100644
index 000000000000..50fe4abb4561
--- /dev/null
+++ b/src/Xanthous/Command.hs
@@ -0,0 +1,20 @@
+module Xanthous.Command where
+
+import Graphics.Vty.Input (Key(..), Modifier(..))
+
+import Xanthous.Prelude hiding (Left, Right, Down)
+import Xanthous.Data (Direction(..))
+
+data Command
+  = Quit
+  | Move Direction
+  | PickUp
+  | PreviousMessage
+
+commandFromKey :: Key -> [Modifier] -> Maybe Command
+commandFromKey (KChar 'q') [] = Just Quit
+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 _ _ = Nothing
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
new file mode 100644
index 000000000000..773f1adc9136
--- /dev/null
+++ b/src/Xanthous/Data.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- | Common data types for Xanthous
+--------------------------------------------------------------------------------
+module Xanthous.Data
+  ( Position(..)
+  , x
+  , y
+
+  , Positioned(..)
+  , position
+  , positioned
+  , loc
+
+    -- *
+  , Direction(..)
+  , opposite
+  , move
+  , asPosition
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (Left, Down, Right)
+import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
+import Test.QuickCheck.Arbitrary.Generic
+import Data.Group
+import Brick (Location(Location))
+--------------------------------------------------------------------------------
+import Xanthous.Util (EqEqProp(..), EqProp)
+--------------------------------------------------------------------------------
+
+data Position where
+  Position :: { _x :: Int
+             , _y :: Int
+             } -> Position
+  deriving stock (Show, Eq, Generic, Ord)
+  deriving anyclass (Hashable, CoArbitrary, Function)
+  deriving EqProp via EqEqProp Position
+makeLenses ''Position
+
+instance Arbitrary Position where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Semigroup Position where
+  (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂)
+
+instance Monoid Position where
+  mempty = Position 0 0
+
+instance Group Position where
+  invert (Position px py) = Position (-px) (-py)
+
+data Positioned a where
+  Positioned :: Position -> a -> Positioned a
+  deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  deriving anyclass (CoArbitrary, Function)
+
+instance Arbitrary a => Arbitrary (Positioned a) where
+  arbitrary = Positioned <$> arbitrary <*> arbitrary
+
+position :: Lens' (Positioned a) Position
+position = lens
+  (\(Positioned pos _) -> pos)
+  (\(Positioned _ a) pos -> Positioned pos a)
+
+positioned :: Lens (Positioned a) (Positioned b) a b
+positioned = lens
+  (\(Positioned _ x') -> x')
+  (\(Positioned pos _) x' -> Positioned pos x')
+
+loc :: Iso' Position Location
+loc = iso hither yon
+  where
+    hither (Position px py) = Location (px, py)
+    yon (Location (lx, ly)) = Position lx ly
+
+--------------------------------------------------------------------------------
+
+data Direction where
+  Up        :: Direction
+  Down      :: Direction
+  Left      :: Direction
+  Right     :: Direction
+  UpLeft    :: Direction
+  UpRight   :: Direction
+  DownLeft  :: Direction
+  DownRight :: Direction
+  deriving stock (Show, Eq, Generic)
+
+instance Arbitrary Direction where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+opposite :: Direction -> Direction
+opposite Up        = Down
+opposite Down      = Up
+opposite Left      = Right
+opposite Right     = Left
+opposite UpLeft    = DownRight
+opposite UpRight   = DownLeft
+opposite DownLeft  = UpRight
+opposite DownRight = UpLeft
+
+move :: Direction -> Position -> Position
+move Up        = y -~ 1
+move Down      = y +~ 1
+move Left      = x -~ 1
+move Right     = x +~ 1
+move UpLeft    = move Up . move Left
+move UpRight   = move Up . move Right
+move DownLeft  = move Down . move Left
+move DownRight = move Down . move Right
+
+asPosition :: Direction -> Position
+asPosition dir = move dir mempty
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
new file mode 100644
index 000000000000..e3ceb6f65182
--- /dev/null
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+module Xanthous.Data.EntityMap
+  ( EntityMap
+  , EntityID
+  , emptyEntityMap
+  , insertAt
+  , insertAtReturningID
+  , atPosition
+  , positions
+  , lookup
+  , lookupWithPosition
+  -- , positionedEntities
+  ) where
+
+import Data.Monoid (Endo(..))
+import Test.QuickCheck (Arbitrary(..))
+import Test.QuickCheck.Checkers (EqProp)
+
+import Xanthous.Prelude hiding (lookup)
+import Xanthous.Data (Position, Positioned(..), positioned, position)
+import Xanthous.Orphans ()
+import Xanthous.Util (EqEqProp(..))
+
+type EntityID = Word32
+type NonNullVector a = NonNull (Vector a)
+
+data EntityMap a where
+  EntityMap ::
+    { _byPosition :: Map Position (NonNullVector EntityID)
+    , _byID       :: HashMap EntityID (Positioned a)
+    , _lastID     :: EntityID
+    } -> EntityMap a
+  deriving stock (Functor, Foldable, Traversable)
+deriving via (EqEqProp (EntityMap a)) instance Eq a => EqProp (EntityMap a)
+makeLenses ''EntityMap
+
+byIDInvariantError :: forall a. a
+byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
+  <> "must point to entityIDs in byID"
+
+instance Eq a => Eq (EntityMap a) where
+  em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap
+
+instance Show a => Show (EntityMap a) where
+  show em = "_EntityMap # " <> show (em ^. _EntityMap)
+
+instance Arbitrary a => Arbitrary (EntityMap a) where
+  arbitrary = review _EntityMap <$> arbitrary
+
+type instance Index (EntityMap a) = EntityID
+type instance IxValue (EntityMap a) = (Positioned a)
+instance Ixed (EntityMap a) where ix eid = at eid . traverse
+
+instance At (EntityMap a) where
+  at eid = lens (view $ byID . at eid) setter
+    where
+      setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a
+      setter m Nothing = fromMaybe m $ do
+        Positioned pos _ <- m ^. byID . at eid
+        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
+      removeEIDAtPos pos =
+        byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid))
+
+emptyEntityMap :: EntityMap a
+emptyEntityMap = EntityMap mempty mempty 0
+
+_EntityMap :: Iso' (EntityMap a) [(Position, a)]
+_EntityMap = iso hither yon
+  where
+    hither :: EntityMap a -> [(Position, a)]
+    hither em = do
+       (pos, eids) <- em ^. byPosition . _Wrapped
+       eid <- toList eids
+       ent <- em ^.. byID . at eid . folded . positioned
+       pure (pos, ent)
+    yon :: [(Position, a)] -> EntityMap a
+    yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap
+
+instance Semigroup (EntityMap a) where
+  em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₁ ^. _EntityMap) em₂
+
+instance Monoid (EntityMap a) where
+  mempty = emptyEntityMap
+
+
+insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a)
+insertAtReturningID pos e em =
+  let (eid, em') = em & lastID <+~ 1
+  in em'
+     & byID . at eid ?~ Positioned pos e
+     & byPosition . at pos %~ \case
+       Nothing -> Just $ ncons eid mempty
+       Just es -> Just $ eid <| es
+     & (eid, )
+
+insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
+insertAt pos e = snd . insertAtReturningID pos e
+
+atPosition :: forall a. Position -> Lens' (EntityMap a) (Vector a)
+atPosition pos = lens getter setter
+  where
+    getter em =
+      let
+        eids :: Vector EntityID
+        eids = maybe mempty toNullable $ em ^. byPosition . at pos
+
+        getEIDAssume :: EntityID -> a
+        getEIDAssume eid = fromMaybe byIDInvariantError
+          $ em ^? byID . ix eid . positioned
+      in getEIDAssume <$> eids
+    setter em Empty = em & byPosition . at pos .~ Nothing
+    setter em entities = alaf Endo foldMap (insertAt pos) entities em
+
+positions :: EntityMap a -> [Position]
+positions = toListOf $ byPosition . to keys . folded
+
+lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a)
+lookupWithPosition eid = view $ byID . at eid
+
+lookup :: EntityID -> EntityMap a -> Maybe a
+lookup eid = fmap (view positioned) . lookupWithPosition eid
+
+-- unlawful :(
+-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b)
+-- positionedEntities = byID . itraversed
diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
new file mode 100644
index 000000000000..6851a7a5d506
--- /dev/null
+++ b/src/Xanthous/Entities.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Xanthous.Entities
+  ( Draw(..)
+  , DrawCharacter(..)
+  , DrawStyledCharacter(..)
+  , Entity
+
+  , Color(..)
+  , KnownColor(..)
+  ) where
+
+import Xanthous.Prelude
+import Brick
+import Data.Typeable
+import qualified Graphics.Vty.Attributes as Vty
+import qualified Graphics.Vty.Image as Vty
+
+class Draw a where
+  draw :: a -> Widget n
+
+newtype DrawCharacter (char :: Symbol) (a :: Type) where
+  DrawCharacter :: a -> DrawCharacter char a
+
+instance KnownSymbol char => Draw (DrawCharacter char a) where
+  draw _ = str $ symbolVal @char Proxy
+
+--------------------------------------------------------------------------------
+
+data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
+
+class KnownColor (color :: Color) where
+  colorVal :: forall proxy. proxy color -> Vty.Color
+
+instance KnownColor 'Black where colorVal _ = Vty.black
+instance KnownColor 'Red where colorVal _ = Vty.red
+instance KnownColor 'Green where colorVal _ = Vty.green
+instance KnownColor 'Yellow where colorVal _ = Vty.yellow
+instance KnownColor 'Blue where colorVal _ = Vty.blue
+instance KnownColor 'Magenta where colorVal _ = Vty.magenta
+instance KnownColor 'Cyan where colorVal _ = Vty.cyan
+instance KnownColor 'White where colorVal _ = Vty.white
+
+newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where
+  DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
+
+instance
+  ( KnownColor fg
+  , KnownColor bg
+  , KnownSymbol char
+  )
+  => Draw (DrawStyledCharacter fg bg char a) where
+  draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
+    where attr = Vty.Attr
+            { Vty.attrStyle = Vty.Default
+            , Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
+            , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
+            , Vty.attrURL = Vty.Default
+            }
+
+--------------------------------------------------------------------------------
+
+class (Show a, Eq a, Draw a) => Entity a
+instance (Show a, Eq a, Draw a) => Entity a
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
new file mode 100644
index 000000000000..5cf397e82232
--- /dev/null
+++ b/src/Xanthous/Entities/Character.hs
@@ -0,0 +1,21 @@
+module Xanthous.Entities.Character
+  ( Character(..)
+  , mkCharacter
+  ) where
+
+import Xanthous.Prelude
+import Test.QuickCheck
+
+import Xanthous.Entities
+
+data Character where
+  Character :: Character
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (CoArbitrary, Function)
+  deriving Draw via (DrawCharacter "@" Character)
+
+instance Arbitrary Character where
+  arbitrary = pure Character
+
+mkCharacter :: Character
+mkCharacter = Character
diff --git a/src/Xanthous/Entities/SomeEntity.hs b/src/Xanthous/Entities/SomeEntity.hs
new file mode 100644
index 000000000000..029247de9b7f
--- /dev/null
+++ b/src/Xanthous/Entities/SomeEntity.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE GADTs #-}
+module Xanthous.Entities.SomeEntity
+  ( SomeEntity(..)
+  , downcastEntity
+  ) where
+
+import Xanthous.Prelude
+import Test.QuickCheck (Arbitrary(..))
+import qualified Test.QuickCheck.Gen as Gen
+
+import Xanthous.Entities (Draw(..), Entity)
+import Data.Typeable
+import Xanthous.Entities.Character
+
+data SomeEntity where
+  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
+
+instance Show SomeEntity where
+  show (SomeEntity x) = "SomeEntity (" <> show x <> ")"
+
+instance Eq SomeEntity where
+  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> a == b
+    _ -> False
+
+instance Arbitrary SomeEntity where
+  arbitrary = Gen.oneof
+    [pure $ SomeEntity Character]
+
+instance Draw SomeEntity where
+  draw (SomeEntity ent) = draw ent
+
+downcastEntity :: (Entity a, Typeable a) => SomeEntity -> Maybe a
+downcastEntity (SomeEntity e) = cast e
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index c88509819cbb..3ca00afbbda1 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -1,12 +1,73 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
 module Xanthous.Game
   ( GameState(..)
+  , entities
   , getInitialState
+
+  , positionedCharacter
+  , character
+  , characterPosition
   ) where
 
 import Xanthous.Prelude
+import Test.QuickCheck.Arbitrary
+
+import Xanthous.Data.EntityMap (EntityMap, EntityID)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import Xanthous.Data (Positioned, Position(..), positioned, position)
+import Xanthous.Entities
+import Xanthous.Entities.SomeEntity
+import Xanthous.Entities.Character
 
 data GameState = GameState
-  { }
+  { _entities          :: EntityMap SomeEntity
+  , _characterEntityID :: EntityID
+  }
+  deriving stock (Show, Eq)
+makeLenses ''GameState
+
+instance Arbitrary GameState where
+  arbitrary = do
+    ents <- arbitrary
+    char <- arbitrary
+    pure $ getInitialState
+      & entities .~ ents
+      & positionedCharacter .~ char
+
+getInitialState :: GameState
+getInitialState =
+  let char = mkCharacter
+      (_characterEntityID, _entities)
+        = EntityMap.insertAtReturningID
+          (Position 0 0)
+          (SomeEntity char)
+          mempty
+  in GameState {..}
+
+positionedCharacter :: Lens' GameState (Positioned Character)
+positionedCharacter = lens getPositionedCharacter setPositionedCharacter
+  where
+    setPositionedCharacter :: GameState -> Positioned Character -> GameState
+    setPositionedCharacter game char
+      = game
+      &  entities . at (game ^. characterEntityID)
+      ?~ fmap SomeEntity char
+
+    getPositionedCharacter :: GameState -> Positioned Character
+    getPositionedCharacter game
+      = over positioned
+        ( fromMaybe (error "Invariant error: Character was not a character!")
+        . downcastEntity
+        )
+      . fromMaybe (error "Invariant error: Character not found!")
+      $ EntityMap.lookupWithPosition
+        (game ^. characterEntityID)
+        (game ^. entities)
+
+
+character :: Lens' GameState Character
+character = positionedCharacter . positioned
 
-getInitialState :: IO GameState
-getInitialState = pure GameState
+characterPosition :: Lens' GameState Position
+characterPosition = positionedCharacter . position
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 2d793ba27bd5..79089029ea8d 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -1,28 +1,45 @@
+{-# LANGUAGE ViewPatterns #-}
+
 module Xanthous.Game.Draw
   ( drawGame
   ) where
 
 import Xanthous.Prelude
-import Brick
+import Brick hiding (loc)
 import Brick.Widgets.Border
 import Brick.Widgets.Border.Style
 
-import Xanthous.Game (GameState(..))
+import Xanthous.Data (Position(Position), x, y, loc)
+import Xanthous.Data.EntityMap
+import Xanthous.Entities
+import Xanthous.Game (GameState(..), entities, characterPosition)
 import Xanthous.Resource (Name(..))
 
 drawMessages :: GameState -> Widget Name
 drawMessages _ = str "Welcome to Xanthous! It's dangerous out there, why not stay inside?"
 
+drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name
+drawEntities em@(fromNullable . positions -> Just entityPositions)
+  = vBox rows
+  where
+    maxPosition = maximum entityPositions
+    maxY = maxPosition ^. y
+    maxX = maxPosition ^. x
+    rows = mkRow <$> [0..maxY]
+    mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
+    renderEntityAt pos = maybe (str " ") draw $ em ^? atPosition pos . folded
+drawEntities _ = emptyWidget
+
 drawMap :: GameState -> Widget Name
-drawMap _game
+drawMap game
   = viewport MapViewport Both
-  $ vBox mapRows
-  where
-    -- TODO
-    firstRow = [str "@"] <> replicate 79 (str " ")
-    mapRows = firstRow <> (replicate 20 . hBox . replicate 80 $ str " ")
+  . showCursor Character (game ^. characterPosition . loc)
+  . drawEntities
+  $ game ^. entities
 
 drawGame :: GameState -> [Widget Name]
-drawGame game = pure . withBorderStyle unicode
+drawGame game
+  = pure
+  . withBorderStyle unicode
   $   drawMessages game
   <=> border (drawMap game)
diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs
new file mode 100644
index 000000000000..232eabf4efb1
--- /dev/null
+++ b/src/Xanthous/Orphans.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+-- |
+
+module Xanthous.Orphans () where
+
+import Xanthous.Prelude
+
+instance forall s a.
+  ( Cons s s a a
+  , MonoFoldable s
+  ) => Cons (NonNull s) (NonNull s) a a where
+  _Cons = prism hither yon
+    where
+      hither :: (a, NonNull s) -> NonNull s
+      hither (a, ns) =
+        let s = toNullable ns
+        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')
diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs
index e75c11d7bb56..b769c4fe9007 100644
--- a/src/Xanthous/Prelude.hs
+++ b/src/Xanthous/Prelude.hs
@@ -3,8 +3,11 @@ module Xanthous.Prelude
   , Type
   , Constraint
   , module GHC.TypeLits
+  , module Control.Lens
   ) where
 
-import ClassyPrelude hiding (return)
+import ClassyPrelude hiding
+  (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index)
 import Data.Kind
 import GHC.TypeLits hiding (Text)
+import Control.Lens
diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs
index 2310a68cc26a..aa9020903cfc 100644
--- a/src/Xanthous/Resource.hs
+++ b/src/Xanthous/Resource.hs
@@ -6,6 +6,8 @@ import Xanthous.Prelude
 
 data Name = MapViewport
             -- ^ The main viewport where we display the game content
+          | Character
+            -- ^ The character
           | MessageBox
             -- ^ The box where we display messages to the user
   deriving stock (Show, Eq, Ord)
diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs
new file mode 100644
index 000000000000..377b66cf15cf
--- /dev/null
+++ b/src/Xanthous/Util.hs
@@ -0,0 +1,14 @@
+module Xanthous.Util
+  ( EqEqProp(..)
+  , EqProp(..)
+  ) where
+
+import Xanthous.Prelude
+
+import Test.QuickCheck.Checkers
+
+newtype EqEqProp a = EqEqProp a
+  deriving newtype Eq
+
+instance Eq a => EqProp (EqEqProp a) where
+  (=-=) = eq