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, 30 insertions, 3 deletions

diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index bbcf19ede4af..14b8230218ab 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -31,12 +31,39 @@ module Xanthous.Game
     -- * App monad
   , AppT(..)
 
+    -- * Saving the game
+  , saveGame
+  , loadGame
+  , saved
+
     -- * Debug State
   , DebugState(..)
   , debugState
   , allRevealed
   ) where
 --------------------------------------------------------------------------------
-import Xanthous.Game.State
-import Xanthous.Game.Lenses
-import Xanthous.Game.Arbitrary ()
+import qualified Codec.Compression.Zlib as Zlib
+import           Codec.Compression.Zlib.Internal (DecompressError)
+import qualified Data.Aeson as JSON
+import           System.IO.Unsafe
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Xanthous.Game.State
+import           Xanthous.Game.Lenses
+import           Xanthous.Game.Arbitrary ()
+import           Xanthous.Entities.Entities ()
+--------------------------------------------------------------------------------
+
+saveGame :: GameState -> LByteString
+saveGame = Zlib.compress . JSON.encode
+
+loadGame :: LByteString -> Maybe GameState
+loadGame = JSON.decode <=< decompressZlibMay
+  where
+    decompressZlibMay bs
+      = unsafeDupablePerformIO
+      $ (let r = Zlib.decompress bs in r `seq` pure (Just r))
+      `catch` \(_ :: DecompressError) -> pure Nothing
+
+saved :: Prism' LByteString GameState
+saved = prism' saveGame loadGame