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.

22 files changed, 548 insertions, 85 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 61640c364654..2e9d8c41eef2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -6,6 +6,7 @@ import qualified Options.Applicative as Opt
 import           System.Random
 import           Control.Monad.Random (getRandom)
 import           Control.Exception (finally)
+import           System.Exit (die)
 --------------------------------------------------------------------------------
 import qualified Xanthous.Game as Game
 import           Xanthous.App (makeApp)
@@ -45,6 +46,7 @@ parseRunParams = RunParams
 
 data Command
   = Run RunParams
+  | Load FilePath
   | Generate GeneratorInput Dimensions
 
 parseDimensions :: Opt.Parser Dimensions
@@ -64,6 +66,10 @@ parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser
       (Opt.info
        (Run <$> parseRunParams)
        (Opt.progDesc "Run the game"))
+  <> Opt.command "load"
+      (Opt.info
+       (Load <$> Opt.argument Opt.str (Opt.metavar "FILE"))
+       (Opt.progDesc "Load a saved game"))
   <> Opt.command "generate"
       (Opt.info
        (Generate
@@ -78,6 +84,9 @@ optParser = Opt.info
   (parseCommand <**> Opt.helper)
   (Opt.header "Xanthous: a WIP TUI RPG")
 
+thanks :: IO ()
+thanks = putStr "\n\n" >> putStrLn "Thanks for playing Xanthous!"
+
 runGame :: RunParams -> IO ()
 runGame rparams = do
   app <- makeApp
@@ -94,6 +103,15 @@ runGame rparams = do
     putStr "\n\n"
   pure ()
 
+loadGame :: FilePath -> IO ()
+loadGame saveFile = do
+  app <- makeApp
+  gameState <- maybe (die "Invalid save file!") pure
+              =<< Game.loadGame . fromStrict <$> readFile @IO saveFile
+  _game' <- gameState `deepseq` defaultMain app gameState `finally` thanks
+  pure ()
+
+
 runGenerate :: GeneratorInput -> Dimensions -> IO ()
 runGenerate input dims = do
   randGen <- getStdGen
@@ -109,6 +127,7 @@ runGenerate input dims = do
 
 runCommand :: Command -> IO ()
 runCommand (Run runParams) = runGame runParams
+runCommand (Load saveFile) = loadGame saveFile
 runCommand (Generate input dims) = runGenerate input dims
 
 main :: IO ()
diff --git a/src/Xanthous/AI/Gormlak.hs-boot b/src/Xanthous/AI/Gormlak.hs-boot
new file mode 100644
index 000000000000..391a8a807f8c
--- /dev/null
+++ b/src/Xanthous/AI/Gormlak.hs-boot
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Xanthous.AI.Gormlak where
+
+import Xanthous.Entities
+import Xanthous.Entities.Creature
+
+instance Entity Creature
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 2f27948cdee5..71bf40c427e8 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -8,12 +8,13 @@ import qualified Brick
 import           Brick.Widgets.Edit (handleEditorEvent)
 import           Graphics.Vty.Attributes (defAttr)
 import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
-import           Control.Monad.State (get, MonadState)
+import           Control.Monad.State (get, gets, MonadState)
 import           Control.Monad.Random (MonadRandom)
 import           Control.Monad.State.Class (modify)
 import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
 import qualified Data.Vector as V
+import qualified Data.Yaml as Yaml
 import           System.Exit
 --------------------------------------------------------------------------------
 import           Xanthous.Command
@@ -23,7 +24,6 @@ import           Xanthous.Data
                  , positioned
                  , Position
                  , Ticks
-                 , Position'(Position)
                  , (|*|)
                  )
 import           Xanthous.Data.EntityMap (EntityMap)
@@ -192,6 +192,18 @@ handleCommand Eat = do
   stepGame -- TODO
   continue
 
+handleCommand Save = do
+  -- TODO default save locations / config file?
+  prompt_ @'StringPrompt ["save", "location"] Cancellable
+    $ \(StringResult filename) -> do
+      src <- gets saveGame
+      lift . liftIO $ do
+        writeFile (unpack filename) $ toStrict src
+        exitSuccess
+
+  continue
+
+
 handleCommand ToggleRevealAll = do
   val <- debugState . allRevealed <%= not
   say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ]
diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs
index f2f21160df75..74808443d34c 100644
--- a/src/Xanthous/Command.hs
+++ b/src/Xanthous/Command.hs
@@ -17,6 +17,7 @@ data Command
   | Open
   | Wait
   | Eat
+  | Save
 
     -- | TODO replace with `:` commands
   | ToggleRevealAll
@@ -30,6 +31,7 @@ commandFromKey (KChar ',') [] = Just PickUp
 commandFromKey (KChar 'o') [] = Just Open
 commandFromKey (KChar 'e') [] = Just Eat
 commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
+commandFromKey (KChar 'S') [] = Just Save
 commandFromKey _ _ = Nothing
 
 --------------------------------------------------------------------------------
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index b0d865fa5d79..fdeb71beb5eb 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -64,14 +64,15 @@ module Xanthous.Data
   , Hitpoints(..)
   ) where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude hiding (Left, Down, Right)
+import           Xanthous.Prelude hiding (Left, Down, Right, (.=))
 import           Test.QuickCheck (Arbitrary, CoArbitrary, Function)
 import           Test.QuickCheck.Arbitrary.Generic
 import           Data.Group
 import           Brick (Location(Location), Edges(..))
 import           Data.Monoid (Product(..), Sum(..))
 import           Data.Aeson.Generic.DerivingVia
-import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson
+                 ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
 --------------------------------------------------------------------------------
 import           Xanthous.Util (EqEqProp(..), EqProp)
 import           Xanthous.Orphans ()
@@ -116,6 +117,7 @@ instance Arbitrary a => Arbitrary (Position' a) where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+
 instance Num a => Semigroup (Position' a) where
   (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂)
 
@@ -134,7 +136,7 @@ instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where
 data Positioned a where
   Positioned :: Position -> a -> Positioned a
   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
-  deriving anyclass (CoArbitrary, Function)
+  deriving anyclass (NFData, CoArbitrary, Function)
 type role Positioned representational
 
 _Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b)
@@ -146,6 +148,16 @@ _Positioned = iso hither yon
 instance Arbitrary a => Arbitrary (Positioned a) where
   arbitrary = Positioned <$> arbitrary <*> arbitrary
 
+instance ToJSON a => ToJSON (Positioned a) where
+  toJSON (Positioned pos val) = object
+    [ "position" .= pos
+    , "data" .= val
+    ]
+
+instance FromJSON a => FromJSON (Positioned a) where
+  parseJSON = withObject "Positioned" $ \obj ->
+    Positioned <$> obj .: "position" <*> obj .: "data"
+
 position :: Lens' (Positioned a) Position
 position = lens
   (\(Positioned pos _) -> pos)
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
index a068828a157c..9ca915553594 100644
--- a/src/Xanthous/Data/EntityMap.hs
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -42,9 +42,13 @@ import Xanthous.Orphans ()
 import Xanthous.Util (EqEqProp(..))
 --------------------------------------------------------------------------------
 import Data.Monoid (Endo(..))
-import Test.QuickCheck (Arbitrary(..))
+import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function)
 import Test.QuickCheck.Checkers (EqProp)
+import Test.QuickCheck.Instances.UnorderedContainers ()
+import Test.QuickCheck.Instances.Vector ()
+import Data.Aeson
 --------------------------------------------------------------------------------
+
 type EntityID = Word32
 type NonNullVector a = NonNull (Vector a)
 
@@ -55,9 +59,16 @@ data EntityMap a where
     , _lastID     :: EntityID
     } -> EntityMap a
   deriving stock (Functor, Foldable, Traversable, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
 deriving via (EqEqProp (EntityMap a)) instance Eq a => EqProp (EntityMap a)
 makeLenses ''EntityMap
 
+instance ToJSON a => ToJSON (EntityMap a) where
+  toJSON = toJSON . toEIDsAndPositioned
+
+instance FromJSON a => FromJSON (EntityMap a) where
+  parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON
+
 byIDInvariantError :: forall a. a
 byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
   <> "must point to entityIDs in byID"
@@ -180,7 +191,7 @@ atPositionWithIDs pos em =
   in (id &&& Positioned pos . getEIDAssume em) <$> eids
 
 fromEIDsAndPositioned
-  :: (MonoFoldable mono, Element mono ~ (EntityID, Positioned a))
+  :: forall mono a. (MonoFoldable mono, Element mono ~ (EntityID, Positioned a))
   => mono
   -> EntityMap a
 fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
index ccd3ae42bfc3..7f4efb71d17e 100644
--- a/src/Xanthous/Entities.hs
+++ b/src/Xanthous/Entities.hs
@@ -130,14 +130,7 @@ instance FromJSON EntityChar where
   parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
   parseJSON (Object o) = do
     (EntityChar _char _) <- o .: "char"
-    _style <- o .:? "style" >>= \case
-      Just styleO -> do
-        let attrStyle = Vty.Default -- TODO
-            attrURL = Vty.Default
-        attrForeColor <- styleO .:? "foreground" .!= Vty.Default
-        attrBackColor <- styleO .:? "background" .!= Vty.Default
-        pure Vty.Attr {..}
-      Nothing -> pure Vty.defAttr
+    _style <- o .:? "style" .!= Vty.defAttr
     pure EntityChar {..}
   parseJSON _ = fail "Invalid type, expected string or object"
 
@@ -146,10 +139,7 @@ instance ToJSON EntityChar where
     | styl == Vty.defAttr = String $ chr <| Empty
     | otherwise = object
       [ "char" .= chr
-      , "style" .= object
-        [ "foreground" .= Vty.attrForeColor styl
-        , "background" .= Vty.attrBackColor styl
-        ]
+      , "style" .= styl
       ]
 
 instance Draw EntityChar where
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
 
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
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
diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs
index 610067a375e2..6714a3bc5610 100644
--- a/src/Xanthous/Orphans.hs
+++ b/src/Xanthous/Orphans.hs
@@ -8,20 +8,27 @@ module Xanthous.Orphans
   ( ppTemplate
   ) where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude hiding (elements)
+import           Xanthous.Prelude hiding (elements, (.=))
 --------------------------------------------------------------------------------
 import           Data.Aeson
+import           Data.Aeson.Types (typeMismatch)
 import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Text.Arbitrary ()
 import           Graphics.Vty.Attributes
+import           Brick.Widgets.Edit
+import           Data.Text.Zipper.Generic (GenericTextZipper)
+import           Brick.Widgets.Core (getName)
+import           System.Random (StdGen)
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
 import           Text.Megaparsec (errorBundlePretty)
 import           Text.Megaparsec.Pos
 import           Text.Mustache
 import           Text.Mustache.Type ( showKey )
+import           Control.Monad.State
 --------------------------------------------------------------------------------
+import           Xanthous.Util.JSON
 
 instance forall s a.
   ( Cons s s a a
@@ -96,8 +103,10 @@ concatTextBlocks (x : xs) = x : concatTextBlocks xs
 instance Arbitrary Template where
   arbitrary = do
     template <- concatTextBlocks <$> arbitrary
-    templateName <- arbitrary
-    rest <- arbitrary
+    -- templateName <- arbitrary
+    -- rest <- arbitrary
+    let templateName = "template"
+        rest = mempty
     pure $ Template
       { templateActual = templateName
       , templateCache = rest & at templateName ?~ template
@@ -171,28 +180,45 @@ deriving anyclass instance NFData Node
 deriving anyclass instance NFData Template
 
 instance FromJSON Color where
-  parseJSON = withText "Color" $ \case
-    "black"   -> pure black
-    "red"     -> pure red
-    "green"   -> pure green
-    "yellow"  -> pure yellow
-    "blue"    -> pure blue
-    "magenta" -> pure magenta
-    "cyan"    -> pure cyan
-    "white"   -> pure white
-    _         -> fail "Invalid color"
+  parseJSON (String "black")         = pure black
+  parseJSON (String "red")           = pure red
+  parseJSON (String "green")         = pure green
+  parseJSON (String "yellow")        = pure yellow
+  parseJSON (String "blue")          = pure blue
+  parseJSON (String "magenta")       = pure magenta
+  parseJSON (String "cyan")          = pure cyan
+  parseJSON (String "white")         = pure white
+  parseJSON (String "brightBlack")   = pure brightBlack
+  parseJSON (String "brightRed")     = pure brightRed
+  parseJSON (String "brightGreen")   = pure brightGreen
+  parseJSON (String "brightYellow")  = pure brightYellow
+  parseJSON (String "brightBlue")    = pure brightBlue
+  parseJSON (String "brightMagenta") = pure brightMagenta
+  parseJSON (String "brightCyan")    = pure brightCyan
+  parseJSON (String "brightWhite")   = pure brightWhite
+  parseJSON n@(Number _)             = Color240 <$> parseJSON n
+  parseJSON x                        = typeMismatch "Color" x
 
 instance ToJSON Color where
   toJSON color
-    | color == black = "black"
-    | color == red = "red"
-    | color == green = "green"
-    | color == yellow = "yellow"
-    | color == blue = "blue"
-    | color == magenta = "magenta"
-    | color == cyan = "cyan"
-    | color == white = "white"
-    | otherwise = error "unimplemented"
+    | color == black         = "black"
+    | color == red           = "red"
+    | color == green         = "green"
+    | color == yellow        = "yellow"
+    | color == blue          = "blue"
+    | color == magenta       = "magenta"
+    | color == cyan          = "cyan"
+    | color == white         = "white"
+    | color == brightBlack   = "brightBlack"
+    | color == brightRed     = "brightRed"
+    | color == brightGreen   = "brightGreen"
+    | color == brightYellow  = "brightYellow"
+    | color == brightBlue    = "brightBlue"
+    | color == brightMagenta = "brightMagenta"
+    | color == brightCyan    = "brightCyan"
+    | color == brightWhite   = "brightWhite"
+    | Color240 num <- color  = toJSON num
+    | otherwise             = error $ "unimplemented: " <> show color
 
 instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
   parseJSON Null                   = pure Default
@@ -207,7 +233,9 @@ instance ToJSON a => ToJSON (MaybeDefault a) where
 --------------------------------------------------------------------------------
 
 instance Arbitrary Color where
-  arbitrary = genericArbitrary
+  arbitrary = oneof [ Color240 <$> choose (0, 239)
+                    , ISOColor <$> choose (0, 15)
+                    ]
 
 deriving anyclass instance CoArbitrary Color
 deriving anyclass instance Function Color
@@ -236,3 +264,89 @@ instance Arbitrary Attr where
 
 deriving anyclass instance CoArbitrary Attr
 deriving anyclass instance Function Attr
+
+instance ToJSON Attr where
+  toJSON Attr{..} = object
+    [ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle
+    , "foreground" .= attrForeColor
+    , "background" .= attrBackColor
+    , "url" .= attrURL
+    ]
+    where
+      maybeDefaultToJSONWith _ Default = Null
+      maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent"
+      maybeDefaultToJSONWith tj (SetTo x) = tj x
+      styleToJSON style
+        | style == standout     = "standout"
+        | style == underline    = "underline"
+        | style == reverseVideo = "reverseVideo"
+        | style == blink        = "blink"
+        | style == dim          = "dim"
+        | style == bold         = "bold"
+        | style == italic       = "italic"
+        | otherwise            = toJSON style
+
+instance FromJSON Attr where
+  parseJSON = withObject "Attr" $ \obj -> do
+    attrStyle <- parseStyle =<< obj .:? "style" .!= Default
+    attrForeColor <- obj .:? "foreground" .!= Default
+    attrBackColor <- obj .:? "background" .!= Default
+    attrURL <- obj .:? "url" .!= Default
+    pure Attr{..}
+
+    where
+      parseStyle (SetTo (String "standout"))     = pure (SetTo standout)
+      parseStyle (SetTo (String "underline"))    = pure (SetTo underline)
+      parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo)
+      parseStyle (SetTo (String "blink"))        = pure (SetTo blink)
+      parseStyle (SetTo (String "dim"))          = pure (SetTo dim)
+      parseStyle (SetTo (String "bold"))         = pure (SetTo bold)
+      parseStyle (SetTo (String "italic"))       = pure (SetTo italic)
+      parseStyle (SetTo n@(Number _))            = SetTo <$> parseJSON n
+      parseStyle (SetTo v)                       = typeMismatch "Style" v
+      parseStyle Default                         = pure Default
+      parseStyle KeepCurrent                     = pure KeepCurrent
+
+--------------------------------------------------------------------------------
+
+instance NFData a => NFData (NonNull a) where
+  rnf xs = xs `seq` toNullable xs `deepseq` ()
+
+instance forall t name. (NFData t, Monoid t, NFData name)
+                 => NFData (Editor t name) where
+  rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` ()
+
+instance NFData StdGen where
+  -- StdGen's fields are bang-patterned so this is actually correct!
+  rnf sg = sg `seq` ()
+
+deriving via (ReadShowJSON StdGen) instance ToJSON StdGen
+deriving via (ReadShowJSON StdGen) instance FromJSON StdGen
+
+instance Function StdGen where
+  function = functionShow
+
+--------------------------------------------------------------------------------
+
+instance CoArbitrary a => CoArbitrary (NonNull a) where
+  coarbitrary = coarbitrary . toNullable
+
+instance (MonoFoldable a, Function a) => Function (NonNull a) where
+  function = functionMap toNullable $ fromMaybe (error "null") . fromNullable
+
+instance (Arbitrary t, Arbitrary n, GenericTextZipper t)
+       => Arbitrary (Editor t n) where
+  arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t)
+              => CoArbitrary (Editor t n) where
+  coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed)
+
+instance CoArbitrary StdGen where
+  coarbitrary = coarbitrary . show
+
+--------------------------------------------------------------------------------
+
+deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s)))
+            => CoArbitrary (StateT s m a)
+
diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs
index 782fd5040d93..13f7e539679b 100644
--- a/src/Xanthous/Resource.hs
+++ b/src/Xanthous/Resource.hs
@@ -1,8 +1,13 @@
+--------------------------------------------------------------------------------
 module Xanthous.Resource
   ( Name(..)
   ) where
-
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Test.QuickCheck
+import Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
 
 data Name = MapViewport
             -- ^ The main viewport where we display the game content
@@ -11,4 +16,8 @@ data Name = MapViewport
           | MessageBox
             -- ^ The box where we display messages to the user
           | Prompt
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary Name where
+  arbitrary = genericArbitrary
diff --git a/src/Xanthous/Util/JSON.hs b/src/Xanthous/Util/JSON.hs
new file mode 100644
index 000000000000..91d1328e4a10
--- /dev/null
+++ b/src/Xanthous/Util/JSON.hs
@@ -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
diff --git a/src/Xanthous/Util/QuickCheck.hs b/src/Xanthous/Util/QuickCheck.hs
new file mode 100644
index 000000000000..ac76a4c930d9
--- /dev/null
+++ b/src/Xanthous/Util/QuickCheck.hs
@@ -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
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 1d8e066ed7a6..69664f8a7940 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -5,6 +5,10 @@ dead:
   - You perish...
   - You have perished...
 
+save:
+  location:
+    "Enter filename to save to: "
+
 entities:
   description: You see here {{entityDescriptions}}