mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement saving+loading the game

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

2
package.yaml
View file

@ -48,9 +48,11 @@ dependencies:
- reflection
- stache
- tomland
- text-zipper
- vector
- vty
- yaml
- zlib
default-extensions:
- BlockArguments

19
src/Main.hs
View file

@ -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 ()

7
src/Xanthous/AI/Gormlak.hs-boot Normal file
View file

@ -0,0 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Xanthous.AI.Gormlak where
import Xanthous.Entities
import Xanthous.Entities.Creature
instance Entity Creature

16
src/Xanthous/App.hs
View file

@ -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 ]

2
src/Xanthous/Command.hs
View file

@ -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
--------------------------------------------------------------------------------

18
src/Xanthous/Data.hs
View file

@ -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)

15
src/Xanthous/Data/EntityMap.hs
View file

@ -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

14
src/Xanthous/Entities.hs
View file

@ -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

25
src/Xanthous/Entities/Arbitrary.hs
View file

@ -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
]

2
src/Xanthous/Entities/Character.hs
View file

@ -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

54
src/Xanthous/Entities/Entities.hs Normal file
View file

@ -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

13
src/Xanthous/Entities/Environment.hs
View file

@ -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

4
src/Xanthous/Entities/Item.hs
View file

@ -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

33
src/Xanthous/Game.hs
View file

@ -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

9
src/Xanthous/Game/Arbitrary.hs
View file

@ -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)

1
src/Xanthous/Game/Lenses.hs
View file

@ -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

98
src/Xanthous/Game/Prompt.hs
View file

@ -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) ""

79
src/Xanthous/Game/State.hs
View file

@ -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

160
src/Xanthous/Orphans.hs
View file

@ -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)

13
src/Xanthous/Resource.hs
View file

@ -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

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

28
src/Xanthous/Util/QuickCheck.hs Normal file
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

4
src/Xanthous/messages.yaml
View file

@ -5,6 +5,10 @@ dead:
- You perish...
- You have perished...
save:
location:
"Enter filename to save to: "
entities:
description: You see here {{entityDescriptions}}

2
test/Spec.hs
View file

@ -1,6 +1,7 @@
import Test.Prelude
import qualified Xanthous.Data.EntityMapSpec
import qualified Xanthous.DataSpec
import qualified Xanthous.EntitiesSpec
import qualified Xanthous.Entities.RawsSpec
import qualified Xanthous.GameSpec
import qualified Xanthous.Generators.UtilSpec
@ -16,6 +17,7 @@ main = defaultMain test
test :: TestTree
test = testGroup "Xanthous"
[ Xanthous.Data.EntityMapSpec.test
, Xanthous.EntitiesSpec.test
, Xanthous.Entities.RawsSpec.test
, Xanthous.GameSpec.test
, Xanthous.Generators.UtilSpec.test

1
test/Test/Prelude.hs
View file

@ -13,6 +13,7 @@ import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
import Test.QuickCheck.Classes
import Test.QuickCheck.Checkers (TestBatch)
import Test.QuickCheck.Instances.ByteString ()
testBatch :: TestBatch -> TestTree
testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests

11
test/Xanthous/Data/EntityMapSpec.hs
View file

@ -2,9 +2,11 @@
--------------------------------------------------------------------------------
module Xanthous.Data.EntityMapSpec where
--------------------------------------------------------------------------------
import Test.Prelude
import Test.Prelude
--------------------------------------------------------------------------------
import Xanthous.Data.EntityMap
import qualified Data.Aeson as JSON
--------------------------------------------------------------------------------
import Xanthous.Data.EntityMap
--------------------------------------------------------------------------------
main :: IO ()
@ -30,4 +32,9 @@ test = localOption (QuickCheckTests 20)
then (em₁ == em₃)
else True
]
, testGroup "JSON encoding/decoding"
[ testProperty "Preserves IDs" $ \(em :: EntityMap Int) ->
let Just em' = JSON.decode $ JSON.encode em
in toEIDsAndPositioned em' === toEIDsAndPositioned em
]
]

20
test/Xanthous/EntitiesSpec.hs Normal file
View file

@ -0,0 +1,20 @@
--------------------------------------------------------------------------------
module Xanthous.EntitiesSpec where
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import qualified Data.Aeson as JSON
--------------------------------------------------------------------------------
import Xanthous.Entities
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Entities"
[ testGroup "EntityChar"
[ testProperty "JSON round-trip" $ \(ec :: EntityChar) ->
JSON.decode (JSON.encode ec) === Just ec
]
]

6
test/Xanthous/GameSpec.hs
View file

@ -44,4 +44,10 @@ test
(oextend f . oextend g) mh === oextend (f . oextend g) mh
]
]
, testGroup "Saving the game"
[ testProperty "forms a prism" $ isPrism saved
, testProperty "preserves the character ID" $ \gs ->
let Just gs' = loadGame $ saveGame gs
in gs' ^. character === gs ^. character
]
]

25
test/Xanthous/OrphansSpec.hs
View file

@ -1,12 +1,16 @@
{-# LANGUAGE BlockArguments #-}
--------------------------------------------------------------------------------
module Xanthous.OrphansSpec where
import Test.Prelude
import Xanthous.Orphans
import Text.Mustache
import Text.Megaparsec (errorBundlePretty)
import Xanthous.Orphans ()
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import Text.Mustache
import Text.Megaparsec (errorBundlePretty)
import Graphics.Vty.Attributes
import qualified Data.Aeson as JSON
--------------------------------------------------------------------------------
import Xanthous.Orphans
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
@ -27,5 +31,12 @@ test = testGroup "Xanthous.Orphans"
$ Right expected === do
(Template actual cache) <- res
maybe (Left "Template not found") Right $ cache ^? at actual
, testProperty "JSON round trip" $ \(tpl :: Template) ->
counterexample (unpack $ ppTemplate tpl)
$ JSON.decode (JSON.encode tpl) === Just tpl
]
, testGroup "Attr"
[ testProperty "JSON round trip" $ \(attr :: Attr) ->
JSON.decode (JSON.encode attr) === Just attr
]
]

17
xanthous.cabal
View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: ac15bf59fd57f7a0bc23f010aec83824f819592494145cbce3e1db36e23f1107
-- hash: 0ec32d45d89e30640d8d59137c5eaa80e5eed7eb31cb553d9b251db94ed1ba36
name: xanthous
version: 0.1.0.0
@ -37,10 +37,10 @@ library
Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics
Xanthous.Entities
Xanthous.Entities.Arbitrary
Xanthous.Entities.Character
Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util
Xanthous.Entities.Entities
Xanthous.Entities.Environment
Xanthous.Entities.Item
Xanthous.Entities.Raws
@ -64,6 +64,8 @@ library
Xanthous.Util
Xanthous.Util.Graphics
Xanthous.Util.Inflection
Xanthous.Util.JSON
Xanthous.Util.QuickCheck
other-modules:
Paths_xanthous
hs-source-dirs:
@ -102,10 +104,12 @@ library
, raw-strings-qq
, reflection
, stache
, text-zipper
, tomland
, vector
, vty
, yaml
, zlib
default-language: Haskell2010
executable xanthous
@ -119,10 +123,10 @@ executable xanthous
Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics
Xanthous.Entities
Xanthous.Entities.Arbitrary
Xanthous.Entities.Character
Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util
Xanthous.Entities.Entities
Xanthous.Entities.Environment
Xanthous.Entities.Item
Xanthous.Entities.Raws
@ -146,6 +150,8 @@ executable xanthous
Xanthous.Util
Xanthous.Util.Graphics
Xanthous.Util.Inflection
Xanthous.Util.JSON
Xanthous.Util.QuickCheck
Paths_xanthous
hs-source-dirs:
src
@ -183,11 +189,13 @@ executable xanthous
, raw-strings-qq
, reflection
, stache
, text-zipper
, tomland
, vector
, vty
, xanthous
, yaml
, zlib
default-language: Haskell2010
test-suite test
@ -198,6 +206,7 @@ test-suite test
Xanthous.Data.EntityMapSpec
Xanthous.DataSpec
Xanthous.Entities.RawsSpec
Xanthous.EntitiesSpec
Xanthous.GameSpec
Xanthous.Generators.UtilSpec
Xanthous.MessageSpec
@ -246,9 +255,11 @@ test-suite test
, tasty
, tasty-hunit
, tasty-quickcheck
, text-zipper
, tomland
, vector
, vty
, xanthous
, yaml
, zlib
default-language: Haskell2010