From f37d0f75c0b4a77c8e35192c24c6fdb6f2bc4619 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 29 Nov 2019 14:33:52 -0500 Subject: 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. --- src/Xanthous/Entities/Arbitrary.hs | 25 ----------------- src/Xanthous/Entities/Character.hs | 2 +- src/Xanthous/Entities/Entities.hs | 54 ++++++++++++++++++++++++++++++++++++ src/Xanthous/Entities/Environment.hs | 13 +++++++-- src/Xanthous/Entities/Item.hs | 4 ++- 5 files changed, 69 insertions(+), 29 deletions(-) delete mode 100644 src/Xanthous/Entities/Arbitrary.hs create mode 100644 src/Xanthous/Entities/Entities.hs (limited to 'src/Xanthous/Entities') 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 -- cgit 1.4.1