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.

4 files changed, 53 insertions, 9 deletions

diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs
index 2e9714a44eb7..53f03020f346 100644
--- a/test/Xanthous/Data/EntityMapSpec.hs
+++ b/test/Xanthous/Data/EntityMapSpec.hs
@@ -2,9 +2,11 @@
 --------------------------------------------------------------------------------
 module Xanthous.Data.EntityMapSpec where
 --------------------------------------------------------------------------------
-import Test.Prelude
+import           Test.Prelude
 --------------------------------------------------------------------------------
-import Xanthous.Data.EntityMap
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.EntityMap
 --------------------------------------------------------------------------------
 
 main :: IO ()
@@ -30,4 +32,9 @@ test = localOption (QuickCheckTests 20)
         then (em₁ == em₃)
         else True
     ]
+  , testGroup "JSON encoding/decoding"
+    [ testProperty "Preserves IDs" $ \(em :: EntityMap Int) ->
+        let Just em' = JSON.decode $ JSON.encode em
+        in toEIDsAndPositioned em' === toEIDsAndPositioned em
+    ]
   ]
diff --git a/test/Xanthous/EntitiesSpec.hs b/test/Xanthous/EntitiesSpec.hs
new file mode 100644
index 000000000000..14b03f729331
--- /dev/null
+++ b/test/Xanthous/EntitiesSpec.hs
@@ -0,0 +1,20 @@
+--------------------------------------------------------------------------------
+module Xanthous.EntitiesSpec where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Entities
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities"
+  [ testGroup "EntityChar"
+    [ testProperty "JSON round-trip" $ \(ec :: EntityChar) ->
+        JSON.decode (JSON.encode ec) === Just ec
+    ]
+  ]
diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs
index 9f30faca0c98..f9a9c543b90a 100644
--- a/test/Xanthous/GameSpec.hs
+++ b/test/Xanthous/GameSpec.hs
@@ -44,4 +44,10 @@ test
           (oextend f . oextend g) mh === oextend (f . oextend g) mh
       ]
     ]
+  , testGroup "Saving the game"
+    [ testProperty "forms a prism" $ isPrism saved
+    , testProperty "preserves the character ID" $ \gs ->
+        let Just gs' = loadGame $ saveGame gs
+        in gs' ^. character === gs ^. character
+    ]
   ]
diff --git a/test/Xanthous/OrphansSpec.hs b/test/Xanthous/OrphansSpec.hs
index 3fe79ee56313..3740945877ef 100644
--- a/test/Xanthous/OrphansSpec.hs
+++ b/test/Xanthous/OrphansSpec.hs
@@ -1,12 +1,16 @@
 {-# LANGUAGE BlockArguments #-}
+--------------------------------------------------------------------------------
 module Xanthous.OrphansSpec where
-
-import Test.Prelude
-import Xanthous.Orphans
-import Text.Mustache
-import Text.Megaparsec (errorBundlePretty)
-
-import Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Text.Mustache
+import           Text.Megaparsec (errorBundlePretty)
+import           Graphics.Vty.Attributes
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Orphans
+--------------------------------------------------------------------------------
 
 main :: IO ()
 main = defaultMain test
@@ -27,5 +31,12 @@ test = testGroup "Xanthous.Orphans"
           $ Right expected === do
             (Template actual cache) <- res
             maybe (Left "Template not found") Right $ cache ^? at actual
+    , testProperty "JSON round trip" $ \(tpl :: Template) ->
+        counterexample (unpack $ ppTemplate tpl)
+        $ JSON.decode (JSON.encode tpl) === Just tpl
+    ]
+  , testGroup "Attr"
+    [ testProperty "JSON round trip" $ \(attr :: Attr) ->
+        JSON.decode (JSON.encode attr) === Just attr
     ]
   ]