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.
This commit is contained in:
Griffin Smith 2019-11-29 14:33:52 -05:00
parent 2f2e5a0b68
commit f37d0f75c0
30 changed files with 620 additions and 97 deletions

19
src/Xanthous/Util/JSON.hs Normal file
View file

@ -0,0 +1,19 @@
--------------------------------------------------------------------------------
module Xanthous.Util.JSON
( ReadShowJSON(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.Aeson
--------------------------------------------------------------------------------
newtype ReadShowJSON a = ReadShowJSON a
deriving newtype (Read, Show)
instance Show a => ToJSON (ReadShowJSON a) where
toJSON = toJSON . show
instance Read a => FromJSON (ReadShowJSON a) where
parseJSON = withText "readable"
$ maybe (fail "Could not read") pure . readMay

View file

@ -0,0 +1,28 @@
module Xanthous.Util.QuickCheck
( FunctionShow(..)
, functionJSON
, FunctionJSON(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Test.QuickCheck
import Test.QuickCheck.Function
import Test.QuickCheck.Instances.ByteString ()
import Data.Aeson
import Data.Coerce
--------------------------------------------------------------------------------
newtype FunctionShow a = FunctionShow a
deriving newtype (Show, Read)
instance (Show a, Read a) => Function (FunctionShow a) where
function = functionShow
functionJSON :: (ToJSON a, FromJSON a) => (a -> c) -> a :-> c
functionJSON = functionMap encode (headEx . decode)
newtype FunctionJSON a = FunctionJSON a
deriving newtype (ToJSON, FromJSON)
instance (ToJSON a, FromJSON a) => Function (FunctionJSON a) where
function = functionJSON