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.

1 files changed, 15 insertions, 3 deletions

diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index b0d865fa5d79..fdeb71beb5eb 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -64,14 +64,15 @@ module Xanthous.Data
   , Hitpoints(..)
   ) where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude hiding (Left, Down, Right)
+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), Edges(..))
 import           Data.Monoid (Product(..), Sum(..))
 import           Data.Aeson.Generic.DerivingVia
-import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson
+                 ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
 --------------------------------------------------------------------------------
 import           Xanthous.Util (EqEqProp(..), EqProp)
 import           Xanthous.Orphans ()
@@ -116,6 +117,7 @@ instance Arbitrary a => Arbitrary (Position' a) where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+
 instance Num a => Semigroup (Position' a) where
   (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂)
 
@@ -134,7 +136,7 @@ instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where
 data Positioned a where
   Positioned :: Position -> a -> Positioned a
   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
-  deriving anyclass (CoArbitrary, Function)
+  deriving anyclass (NFData, CoArbitrary, Function)
 type role Positioned representational
 
 _Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b)
@@ -146,6 +148,16 @@ _Positioned = iso hither yon
 instance Arbitrary a => Arbitrary (Positioned a) where
   arbitrary = Positioned <$> arbitrary <*> arbitrary
 
+instance ToJSON a => ToJSON (Positioned a) where
+  toJSON (Positioned pos val) = object
+    [ "position" .= pos
+    , "data" .= val
+    ]
+
+instance FromJSON a => FromJSON (Positioned a) where
+  parseJSON = withObject "Positioned" $ \obj ->
+    Positioned <$> obj .: "position" <*> obj .: "data"
+
 position :: Lens' (Positioned a) Position
 position = lens
   (\(Positioned pos _) -> pos)