1 files changed, 54 insertions, 0 deletions
diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs
new file mode 100644
index 000000000000..410a6514ae4f
--- /dev/null
+++ b/src/Xanthous/Entities/Entities.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Entities () where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import qualified Test.QuickCheck.Gen as Gen
+import           Data.Aeson
+--------------------------------------------------------------------------------
+import           Xanthous.Entities (Entity(..), SomeEntity(..))
+import           Xanthous.Entities.Character
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.Creature
+import           Xanthous.Entities.Environment
+import           Xanthous.Game.State
+import           {-# SOURCE #-} Xanthous.AI.Gormlak ()
+import           Xanthous.Util.QuickCheck
+import           Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+
+instance Arbitrary SomeEntity where
+  arbitrary = Gen.oneof
+    [ SomeEntity <$> arbitrary @Character
+    , SomeEntity <$> arbitrary @Item
+    , SomeEntity <$> arbitrary @Creature
+    , SomeEntity <$> arbitrary @Wall
+    , SomeEntity <$> arbitrary @Door
+    ]
+
+instance FromJSON SomeEntity where
+  parseJSON = withObject "Entity" $ \obj -> do
+    (entityType :: Text) <- obj .: "type"
+    case entityType of
+      "Character" -> SomeEntity @Character <$> obj .: "data"
+      "Item" -> SomeEntity @Item <$> obj .: "data"
+      "Creature" -> SomeEntity @Creature <$> obj .: "data"
+      "Wall" -> SomeEntity @Wall <$> obj .: "data"
+      "Door" -> SomeEntity @Door <$> obj .: "data"
+      _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
+
+deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
+  instance FromJSON GameState
+
+instance Entity SomeEntity where
+  blocksVision (SomeEntity ent) = blocksVision ent
+  description (SomeEntity ent) = description ent
+
+instance Function SomeEntity where
+  function = functionJSON
+
+instance CoArbitrary SomeEntity where
+  coarbitrary = coarbitrary . encode