diff options
30 files changed, 620 insertions, 97 deletions
diff --git a/package.yaml b/package.yaml index 35f6b56526..a54d3075b7 100644 --- a/package.yaml +++ b/package.yaml @@ -48,9 +48,11 @@ dependencies: - reflection - stache - tomland +- text-zipper - vector - vty - yaml +- zlib default-extensions: - BlockArguments diff --git a/src/Main.hs b/src/Main.hs index 61640c3646..2e9d8c41ee 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 0000000000..391a8a807f --- /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 2f27948cde..71bf40c427 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 f2f21160df..74808443d3 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 b0d865fa5d..fdeb71beb5 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 a068828a15..9ca9155535 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 ccd3ae42bf..7f4efb71d1 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 8ba6447933..0000000000 --- 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 271492d6ce..cc04340f6e 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 0000000000..410a6514ae --- /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 e8190cd42a..8119199631 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 ea6f16e05d..ddd387af8c 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 bbcf19ede4..14b8230218 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 5bba77d5a1..e8f9ae22c4 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 77314a9aea..cd7148442a 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 26a7b96eb1..1154d6db5a 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 e3df5c60de..92c68a3f65 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 610067a375..6714a3bc56 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 782fd5040d..13f7e53967 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 0000000000..91d1328e4a --- /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 0000000000..ac76a4c930 --- /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 1d8e066ed7..69664f8a79 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}} diff --git a/test/Spec.hs b/test/Spec.hs index 27e26862e2..bd31867294 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Test/Prelude.hs b/test/Test/Prelude.hs index b12e1e895d..c423796184 100644 --- a/test/Test/Prelude.hs +++ b/test/Test/Prelude.hs @@ -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 diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs index 2e9714a44e..53f03020f3 100644 --- a/test/Xanthous/Data/EntityMapSpec.hs +++ b/test/Xanthous/Data/EntityMapSpec.hs @@ -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 + ] ] diff --git a/test/Xanthous/EntitiesSpec.hs b/test/Xanthous/EntitiesSpec.hs new file mode 100644 index 0000000000..14b03f7293 --- /dev/null +++ b/test/Xanthous/EntitiesSpec.hs @@ -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 + ] + ] diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs index 9f30faca0c..f9a9c543b9 100644 --- a/test/Xanthous/GameSpec.hs +++ b/test/Xanthous/GameSpec.hs @@ -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 + ] ] diff --git a/test/Xanthous/OrphansSpec.hs b/test/Xanthous/OrphansSpec.hs index 3fe79ee563..3740945877 100644 --- a/test/Xanthous/OrphansSpec.hs +++ b/test/Xanthous/OrphansSpec.hs @@ -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 ] ] diff --git a/xanthous.cabal b/xanthous.cabal index f25521c5bb..7204dc0f0f 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -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 |