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. --- 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 +++++++++++++++ 5 files changed, 173 insertions(+), 6 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 (limited to 'src') 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 -- cgit 1.4.1