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, 178 insertions, 9 deletions

diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
index 5bba77d5a174..e8f9ae22c461 100644
--- a/src/Xanthous/Game/Arbitrary.hs
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -1,4 +1,6 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE RecordWildCards #-}
 --------------------------------------------------------------------------------
 module Xanthous.Game.Arbitrary where
@@ -9,7 +11,7 @@ import           Test.QuickCheck
 import           System.Random
 --------------------------------------------------------------------------------
 import           Xanthous.Game.State
-import           Xanthous.Entities.Arbitrary ()
+import           Xanthous.Entities.Entities ()
 import           Xanthous.Entities.Character
 import qualified Xanthous.Data.EntityMap as EntityMap
 --------------------------------------------------------------------------------
@@ -26,3 +28,8 @@ instance Arbitrary GameState where
     let _promptState = NoPrompt -- TODO
     _debugState <- arbitrary
     pure $ GameState {..}
+
+
+instance CoArbitrary GameState
+instance Function GameState
+deriving newtype instance CoArbitrary (m (a, GameState)) => CoArbitrary (AppT m a)
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index 77314a9aea60..cd7148442ace 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -28,6 +28,7 @@ import           Xanthous.Entities.Character (Character, mkCharacter)
 import           Xanthous.Entities.Environment (Door, open)
 import           Xanthous.Entities.Item (Item)
 import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Entities.Entities ()
 --------------------------------------------------------------------------------
 
 getInitialState :: IO GameState
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
index 26a7b96eb1f2..1154d6db5a4c 100644
--- a/src/Xanthous/Game/Prompt.hs
+++ b/src/Xanthous/Game/Prompt.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE GADTs #-}
 --------------------------------------------------------------------------------
@@ -50,11 +51,19 @@ instance Show PromptType where
 data SPromptType :: PromptType -> Type where
   SStringPrompt    ::      SPromptType 'StringPrompt
   SConfirm         ::      SPromptType 'Confirm
-  SMenu            :: forall a. SPromptType ('Menu a)
+  SMenu            ::      SPromptType ('Menu a)
   SDirectionPrompt ::      SPromptType 'DirectionPrompt
   SPointOnMap      ::      SPromptType 'PointOnMap
   SContinue        ::      SPromptType 'Continue
 
+instance NFData (SPromptType pt) where
+  rnf SStringPrompt = ()
+  rnf SConfirm = ()
+  rnf SMenu = ()
+  rnf SDirectionPrompt = ()
+  rnf SPointOnMap = ()
+  rnf SContinue = ()
+
 class SingPromptType pt where singPromptType :: SPromptType pt
 instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
 instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
@@ -85,15 +94,67 @@ data PromptResult (pt :: PromptType) where
   PointOnMapResult :: Position  -> PromptResult 'PointOnMap
   ContinueResult   ::             PromptResult 'Continue
 
+instance Arbitrary (PromptResult 'StringPrompt) where
+  arbitrary = StringResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'Confirm) where
+  arbitrary = ConfirmResult <$> arbitrary
+
+instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where
+  arbitrary = MenuResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'DirectionPrompt) where
+  arbitrary = DirectionResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'PointOnMap) where
+  arbitrary = PointOnMapResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'Continue) where
+  arbitrary = pure ContinueResult
+
+--------------------------------------------------------------------------------
+
 data PromptState pt where
   StringPromptState    :: Editor Text Name -> PromptState 'StringPrompt
   DirectionPromptState ::                    PromptState 'DirectionPrompt
   ContinuePromptState  ::                    PromptState 'Continue
   MenuPromptState      :: forall a.               PromptState ('Menu a)
 
+instance NFData (PromptState pt) where
+  rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
+  rnf DirectionPromptState = ()
+  rnf ContinuePromptState = ()
+  rnf MenuPromptState = ()
+
+instance Arbitrary (PromptState 'StringPrompt) where
+  arbitrary = StringPromptState <$> arbitrary
+
+instance Arbitrary (PromptState 'DirectionPrompt) where
+  arbitrary = pure DirectionPromptState
+
+instance Arbitrary (PromptState 'Continue) where
+  arbitrary = pure ContinuePromptState
+
+instance Arbitrary (PromptState ('Menu a)) where
+  arbitrary = pure MenuPromptState
+
+instance CoArbitrary (PromptState 'StringPrompt) where
+  coarbitrary (StringPromptState ed) = coarbitrary ed
+
+instance CoArbitrary (PromptState 'DirectionPrompt) where
+  coarbitrary DirectionPromptState = coarbitrary ()
+
+instance CoArbitrary (PromptState 'Continue) where
+  coarbitrary ContinuePromptState = coarbitrary ()
+
+instance CoArbitrary (PromptState ('Menu a)) where
+  coarbitrary MenuPromptState = coarbitrary ()
+
 deriving stock instance Show (PromptState pt)
 
 data MenuOption a = MenuOption Text a
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
 
 mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
             => f
@@ -134,6 +195,41 @@ instance Show (Prompt m) where
             SMenu -> show pri
             _ -> "()"
 
+instance NFData (Prompt m) where
+  rnf (Prompt c SMenu ps pri cb)
+            = c
+    `deepseq` ps
+    `deepseq` pri
+    `seq` cb
+    `seq` ()
+  rnf (Prompt c spt ps pri cb)
+            = c
+    `deepseq` spt
+    `deepseq` ps
+    `deepseq` pri
+    `seq` cb
+    `seq` ()
+
+instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
+  coarbitrary (Prompt c SStringPrompt ps pri cb) =
+    variant @Int 1 . coarbitrary (c, ps, pri, cb)
+  coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state
+    variant @Int 2 . coarbitrary (c, pri, cb)
+  coarbitrary (Prompt c SMenu _ps _pri _cb) =
+    variant @Int 3 . coarbitrary c {-, ps, pri, cb -}
+  coarbitrary (Prompt c SDirectionPrompt ps pri cb) =
+    variant @Int 4 . coarbitrary (c, ps, pri, cb)
+  coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state
+    variant @Int 5 . coarbitrary (c, pri, cb)
+  coarbitrary (Prompt c SContinue ps pri cb) =
+    variant @Int 6 . coarbitrary (c, ps, pri, cb)
+
+-- instance Function (Prompt m) where
+--   function = functionMap toTuple _fromTuple
+--     where
+--       toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb)
+
+
 mkPrompt :: (PromptInput pt ~ ()) => PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
 mkPrompt c pt@SStringPrompt cb =
   let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index e3df5c60def2..92c68a3f65c0 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
@@ -55,6 +56,9 @@ import           Control.Monad.State.Class
 import           Control.Monad.State
 import           Control.Monad.Random.Class
 import           Brick (EventM, Widget)
+import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
+import qualified Data.Aeson as JSON
+import           Data.Aeson.Generic.DerivingVia
 --------------------------------------------------------------------------------
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data
@@ -71,6 +75,9 @@ data MessageHistory
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           MessageHistory
 makeFieldsNoPrefix ''MessageHistory
 
 instance Semigroup MessageHistory where
@@ -118,7 +125,31 @@ previousMessage mh = mh & displayedTurn .~ maximumOf
 data GamePromptState m where
   NoPrompt :: GamePromptState m
   WaitingPrompt :: Text -> Prompt m -> GamePromptState m
-  deriving stock (Show)
+  deriving stock (Show, Generic)
+  deriving anyclass (NFData)
+
+-- | Non-injective! We never try to serialize waiting prompts, since:
+--
+--  * they contain callback functions
+--  * we can't save the game when in a prompt anyway
+instance ToJSON (GamePromptState m) where
+  toJSON _ = Null
+
+-- | Always expects Null
+instance FromJSON (GamePromptState m) where
+  parseJSON Null = pure NoPrompt
+  parseJSON _ = fail "Invalid GamePromptState; expected null"
+
+instance CoArbitrary (GamePromptState m) where
+  coarbitrary NoPrompt = variant @Int 1
+  coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt
+
+instance Function (GamePromptState m) where
+  function = functionMap onlyNoPrompt (const NoPrompt)
+    where
+      onlyNoPrompt NoPrompt = ()
+      onlyNoPrompt (WaitingPrompt _ _) =
+        error "Can't handle prompts in Function!"
 
 --------------------------------------------------------------------------------
 
@@ -171,7 +202,10 @@ brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
 
 --------------------------------------------------------------------------------
 
-class (Show a, Eq a, Draw a, Brain a) => Entity a where
+class ( Show a, Eq a, NFData a
+      , ToJSON a, FromJSON a
+      , Draw a, Brain a
+      ) => Entity a where
   blocksVision :: a -> Bool
   description :: a -> Text
 
@@ -186,6 +220,19 @@ instance Eq SomeEntity where
     Just Refl -> a == b
     _ -> False
 
+instance NFData SomeEntity where
+  rnf (SomeEntity ent) = ent `deepseq` ()
+
+instance ToJSON SomeEntity where
+  toJSON (SomeEntity ent) = entityToJSON ent
+    where
+      entityToJSON :: forall entity. (Entity entity, Typeable entity)
+                   => entity -> JSON.Value
+      entityToJSON entity = JSON.object
+        [ "type" JSON..= tshow (typeRep @_ @entity Proxy)
+        , "data" JSON..= toJSON entity
+        ]
+
 instance Draw SomeEntity where
   drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
   drawPriority (SomeEntity ent) = drawPriority ent
@@ -194,10 +241,6 @@ instance Brain SomeEntity where
   step ticks (Positioned pos (SomeEntity ent)) =
     fmap SomeEntity <$> step ticks (Positioned pos ent)
 
-instance Entity SomeEntity where
-  blocksVision (SomeEntity ent) = blocksVision ent
-  description (SomeEntity ent) = description ent
-
 downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
 downcastEntity (SomeEntity e) = cast e
 
@@ -214,6 +257,10 @@ data DebugState = DebugState
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           DebugState
+{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-}
 
 instance Arbitrary DebugState where
   arbitrary = genericArbitrary
@@ -227,7 +274,11 @@ data GameState = GameState
   , _promptState       :: !(GamePromptState AppM)
   , _debugState        :: DebugState
   }
-  deriving stock (Show)
+  deriving stock (Show, Generic)
+  deriving anyclass (NFData)
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           GameState
 makeLenses ''GameState
 
 instance Eq GameState where
@@ -249,6 +300,20 @@ instance (Monad m) => MonadRandom (AppT m) where
   getRandomRs rng = uses randomGen $ randomRs rng
   getRandoms = uses randomGen randoms
 
+instance (MonadIO m) => MonadIO (AppT m) where
+  liftIO = lift . liftIO
+
 --------------------------------------------------------------------------------
 
 makeLenses ''DebugState
+
+--------------------------------------------------------------------------------
+
+-- saveGame :: GameState -> LByteString
+-- saveGame = Zlib.compress . JSON.encode
+
+-- loadGame :: LByteString -> Maybe GameState
+-- loadGame = JSON.decode . Zlib.decompress
+
+-- saved :: Prism' LByteString GameState
+-- saved = prism' saveGame loadGame