Implement saving+loading the game

Implement ToJSON and FromJSON for all of the various pieces of the game
state, and add a pair of functions saveGame/loadGame implementing a
prism to save the game as zlib-compressed JSON. To test this, there's
now Arbitrary, CoArbitrary, and Function instances for all the parts of
the game state - to get around circular imports with the concrete
entities this unfortunately is happening via orphan instances, plus an
hs-boot file to break a circular import that was just a little too hard
to remove by moving things around. Ugh.

5 files changed, 69 insertions, 29 deletions

diff --git a/src/Xanthous/Entities/Arbitrary.hs b/src/Xanthous/Entities/Arbitrary.hs
deleted file mode 100644
index 8ba6447933b2..000000000000
--- a/src/Xanthous/Entities/Arbitrary.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
---------------------------------------------------------------------------------
-module Xanthous.Entities.Arbitrary () where
---------------------------------------------------------------------------------
-import           Xanthous.Prelude
---------------------------------------------------------------------------------
-import           Test.QuickCheck
-import qualified Test.QuickCheck.Gen as Gen
---------------------------------------------------------------------------------
-import           Xanthous.Entities (SomeEntity(..))
-import           Xanthous.Entities.Character
-import           Xanthous.Entities.Item
-import           Xanthous.Entities.Creature
-import           Xanthous.Entities.Environment
-import           Xanthous.AI.Gormlak ()
---------------------------------------------------------------------------------
-
-instance Arbitrary SomeEntity where
-  arbitrary = Gen.oneof
-    [ SomeEntity <$> arbitrary @Character
-    , SomeEntity <$> arbitrary @Item
-    , SomeEntity <$> arbitrary @Creature
-    , SomeEntity <$> arbitrary @Wall
-    , SomeEntity <$> arbitrary @Door
-    ]
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 271492d6ce26..cc04340f6e24 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -40,7 +40,7 @@ data Character = Character
   , _speed :: TicksPerTile
   }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (CoArbitrary, Function)
+  deriving anyclass (NFData, CoArbitrary, Function)
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
            Character
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
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index e8190cd42a92..811919963122 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -12,6 +12,7 @@ import Test.QuickCheck.Arbitrary.Generic
 import Brick (str)
 import Brick.Widgets.Border.Style (unicode)
 import Brick.Types (Edges(..))
+import Data.Aeson
 --------------------------------------------------------------------------------
 import Xanthous.Entities
        ( Draw(..)
@@ -28,7 +29,15 @@ import Xanthous.Data
 
 data Wall = Wall
   deriving stock (Show, Eq, Ord, Generic, Enum)
-  deriving anyclass (CoArbitrary, Function)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance ToJSON Wall where
+  toJSON = const $ String "Wall"
+
+instance FromJSON Wall where
+  parseJSON = withText "Wall" $ \case
+    "Wall" -> pure Wall
+    _      -> fail "Invalid Wall: expected Wall"
 
 -- deriving via Brainless Wall instance Brain Wall
 instance Brain Wall where step = brainVia Brainless
@@ -53,7 +62,7 @@ data Door = Door
   , _locked :: Bool
   }
   deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
 makeLenses ''Door
 
 instance Arbitrary Door where
diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs
index ea6f16e05dc3..ddd387af8c78 100644
--- a/src/Xanthous/Entities/Item.hs
+++ b/src/Xanthous/Entities/Item.hs
@@ -29,13 +29,15 @@ data Item = Item
   { _itemType :: ItemType
   }
   deriving stock (Eq, Show, Generic)
-  deriving anyclass (CoArbitrary, Function)
+  deriving anyclass (NFData, CoArbitrary, Function)
   deriving Draw via DrawRawChar "_itemType" Item
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        Item
 makeLenses ''Item
 
+{-# ANN Item ("HLint: ignore Use newtype instead of data" :: String )#-}
+
 -- deriving via (Brainless Item) instance Brain Item
 instance Brain Item where step = brainVia Brainless