From 4d270712aecf1b61249086718852b96968de2bd8 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Mon, 2 Sep 2019 13:56:25 -0400 Subject: Add raws, loaded statically from a folder Add raw types with support for both creatures and items, loaded statically from a "raws" folder just like in the Rust version. --- package.yaml | 1 + src/Xanthous/Data.hs | 48 +++++++++++++++++++++---- src/Xanthous/Entities/RawTypes.hs | 62 +++++++++++++++++++++++++++++++++ src/Xanthous/Entities/Raws.hs | 28 +++++++++++++++ src/Xanthous/Entities/Raws/gormlak.yaml | 12 +++++++ src/Xanthous/Orphans.hs | 29 +++++++++++++++ test/Spec.hs | 6 ++-- test/Xanthous/DataSpec.hs | 2 +- test/Xanthous/Entities/RawsSpec.hs | 16 +++++++++ xanthous.cabal | 10 +++++- 10 files changed, 204 insertions(+), 10 deletions(-) create mode 100644 src/Xanthous/Entities/RawTypes.hs create mode 100644 src/Xanthous/Entities/Raws.hs create mode 100644 src/Xanthous/Entities/Raws/gormlak.yaml create mode 100644 test/Xanthous/Entities/RawsSpec.hs diff --git a/package.yaml b/package.yaml index 2aa6bd9b58d8..9ea1ee521712 100644 --- a/package.yaml +++ b/package.yaml @@ -29,6 +29,7 @@ dependencies: - data-default - deepseq - file-embed +- filepath - generic-arbitrary - generic-monoid - groups diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index 773f1adc9136..e891a8e9e0d6 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -20,15 +21,23 @@ module Xanthous.Data , opposite , move , asPosition + + -- * + , EntityChar(..) ) where -------------------------------------------------------------------------------- -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)) +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), raw) +import Graphics.Vty.Attributes +import qualified Graphics.Vty.Image as Vty +import Data.Aeson -------------------------------------------------------------------------------- -import Xanthous.Util (EqEqProp(..), EqProp) +import Xanthous.Util (EqEqProp(..), EqProp) +import Xanthous.Orphans () +import Xanthous.Entities (Draw(..)) -------------------------------------------------------------------------------- data Position where @@ -116,3 +125,30 @@ move DownRight = move Down . move Right asPosition :: Direction -> Position asPosition dir = move dir mempty + +-------------------------------------------------------------------------------- + +data EntityChar = EntityChar + { _char :: Char + , _style :: Attr + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +instance FromJSON EntityChar where + parseJSON (String (chr :< Empty)) = pure $ EntityChar chr defAttr + parseJSON (Object o) = do + (EntityChar _char _) <- o .: "char" + _style <- o .:? "style" >>= \case + Just styleO -> do + let attrStyle = Default -- TODO + attrURL = Default + attrForeColor <- styleO .:? "foreground" .!= Default + attrBackColor <- styleO .:? "background" .!= Default + pure Attr {..} + Nothing -> pure defAttr + pure EntityChar {..} + parseJSON _ = fail "Invalid type, expected string or object" + +instance Draw EntityChar where + draw EntityChar{..} = raw $ Vty.string _style [_char] diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs new file mode 100644 index 000000000000..e82cb0c890c7 --- /dev/null +++ b/src/Xanthous/Entities/RawTypes.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Xanthous.Entities.RawTypes + ( CreatureType(..) + , ItemType(..) + , EntityRaw(..) + + , HasName(..) + , HasDescription(..) + , HasLongDescription(..) + , HasChar(..) + , HasMaxHitpoints(..) + , HasFriendly(..) + , _Creature + ) where + +import Xanthous.Prelude +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (FromJSON) +import Data.Word + +import Xanthous.Data + +data CreatureType = CreatureType + { _name :: Text + , _description :: Text + , _char :: EntityChar + , _maxHitpoints :: Word16 + , _friendly :: Bool + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + CreatureType +makeFieldsNoPrefix ''CreatureType + +data ItemType = ItemType + { _name :: Text + , _description :: Text + , _longDescription :: Text + , _char :: EntityChar + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + ItemType +makeFieldsNoPrefix ''ItemType + +data EntityRaw + = Creature CreatureType + | Item ItemType + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (FromJSON) + via WithOptions '[ SumEnc ObjWithSingleField ] + EntityRaw +makePrisms ''EntityRaw + +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} diff --git a/src/Xanthous/Entities/Raws.hs b/src/Xanthous/Entities/Raws.hs new file mode 100644 index 000000000000..4a4cba8c9a19 --- /dev/null +++ b/src/Xanthous/Entities/Raws.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Xanthous.Entities.Raws + ( raws + , raw + ) where + +import Data.FileEmbed +import qualified Data.Yaml as Yaml +import Xanthous.Prelude +import System.FilePath.Posix + +import Xanthous.Entities.RawTypes + +rawRaws :: [(FilePath, ByteString)] +rawRaws = $(embedDir "src/Xanthous/Entities/Raws") + +raws :: HashMap Text EntityRaw +raws + = mapFromList + . map (bimap + (pack . takeBaseName) + (either (error . Yaml.prettyPrintParseException) id + . Yaml.decodeEither')) + $ rawRaws + +raw :: Text -> Maybe EntityRaw +raw n = raws ^. at n diff --git a/src/Xanthous/Entities/Raws/gormlak.yaml b/src/Xanthous/Entities/Raws/gormlak.yaml new file mode 100644 index 000000000000..fc3215f2f451 --- /dev/null +++ b/src/Xanthous/Entities/Raws/gormlak.yaml @@ -0,0 +1,12 @@ +Creature: + name: gormlak + description: | + A chittering imp-like creature with bright yellow horns. It adores shiny objects + and gathers in swarms. + char: + char: g + style: + color: red + maxHitpoints: 5 + speed: 120 + friendly: false diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs index d2e378cd2817..3efe1f1264c2 100644 --- a/src/Xanthous/Orphans.hs +++ b/src/Xanthous/Orphans.hs @@ -18,6 +18,7 @@ import Text.Mustache.Type ( showKey ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Aeson +import Graphics.Vty.Attributes instance forall s a. ( Cons s s a a @@ -152,3 +153,31 @@ instance Function Text where 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" + +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" + +instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where + parseJSON Null = pure Default + parseJSON x = SetTo <$> parseJSON x diff --git a/test/Spec.hs b/test/Spec.hs index 6f955aa6964d..7ae9b40d267e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,15 +4,17 @@ import qualified Xanthous.Data.EntityMapSpec import qualified Xanthous.GameSpec import qualified Xanthous.MessageSpec import qualified Xanthous.OrphansSpec +import qualified Xanthous.Entities.RawsSpec main :: IO () main = defaultMain test test :: TestTree test = testGroup "Xanthous" - [ Xanthous.DataSpec.test - , Xanthous.Data.EntityMapSpec.test + [ Xanthous.Data.EntityMapSpec.test + , Xanthous.Entities.RawsSpec.test , Xanthous.GameSpec.test , Xanthous.MessageSpec.test , Xanthous.OrphansSpec.test + , Xanthous.DataSpec.test ] diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs index ba060b7ad289..2c9f9dd3f9b1 100644 --- a/test/Xanthous/DataSpec.hs +++ b/test/Xanthous/DataSpec.hs @@ -1,6 +1,6 @@ -- | -module Xanthous.DataSpec where +module Xanthous.DataSpec (main, test) where import Test.Prelude hiding (Right, Left, Down) import Xanthous.Data diff --git a/test/Xanthous/Entities/RawsSpec.hs b/test/Xanthous/Entities/RawsSpec.hs new file mode 100644 index 000000000000..2e6f35457fc7 --- /dev/null +++ b/test/Xanthous/Entities/RawsSpec.hs @@ -0,0 +1,16 @@ +-- | + +module Xanthous.Entities.RawsSpec (main, test) where + +import Test.Prelude +import Xanthous.Entities.Raws + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Entities.Raws" + [ testGroup "raws" + [ testCase "are all valid" $ raws `deepseq` pure () + ] + ] diff --git a/xanthous.cabal b/xanthous.cabal index 8c6fe406ae1e..390d0dbfc33e 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 5d750bf0bb5c6d278928f6c9606427754a444344fd769f50c02b776dedf0e771 +-- hash: 897c9cda436c62269dd43a0fc47226b24a310e52522fa6ebfe18cedc2394f6ea name: xanthous version: 0.1.0.0 @@ -36,6 +36,8 @@ library Xanthous.Data.EntityMap Xanthous.Entities Xanthous.Entities.Character + Xanthous.Entities.Raws + Xanthous.Entities.RawTypes Xanthous.Entities.SomeEntity Xanthous.Game Xanthous.Game.Draw @@ -65,6 +67,7 @@ library , data-default , deepseq , file-embed + , filepath , generic-arbitrary , generic-monoid , groups @@ -92,6 +95,8 @@ executable xanthous Xanthous.Data.EntityMap Xanthous.Entities Xanthous.Entities.Character + Xanthous.Entities.Raws + Xanthous.Entities.RawTypes Xanthous.Entities.SomeEntity Xanthous.Game Xanthous.Game.Draw @@ -120,6 +125,7 @@ executable xanthous , data-default , deepseq , file-embed + , filepath , generic-arbitrary , generic-monoid , groups @@ -145,6 +151,7 @@ test-suite test Test.Prelude Xanthous.Data.EntityMapSpec Xanthous.DataSpec + Xanthous.Entities.RawsSpec Xanthous.GameSpec Xanthous.MessageSpec Xanthous.OrphansSpec @@ -166,6 +173,7 @@ test-suite test , data-default , deepseq , file-embed + , filepath , generic-arbitrary , generic-monoid , groups -- cgit 1.4.1