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.
This commit is contained in:
Griffin Smith 2019-09-02 13:56:25 -04:00
parent 243104c410
commit 4d270712ae
10 changed files with 204 additions and 10 deletions

View file

@ -29,6 +29,7 @@ dependencies:
- data-default
- deepseq
- file-embed
- filepath
- generic-arbitrary
- generic-monoid
- groups

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -1,6 +1,6 @@
-- |
module Xanthous.DataSpec where
module Xanthous.DataSpec (main, test) where
import Test.Prelude hiding (Right, Left, Down)
import Xanthous.Data

View file

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

View file

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