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:
parent
243104c410
commit
4d270712ae
10 changed files with 204 additions and 10 deletions
|
@ -29,6 +29,7 @@ dependencies:
|
|||
- data-default
|
||||
- deepseq
|
||||
- file-embed
|
||||
- filepath
|
||||
- generic-arbitrary
|
||||
- generic-monoid
|
||||
- groups
|
||||
|
|
|
@ -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]
|
||||
|
|
62
src/Xanthous/Entities/RawTypes.hs
Normal file
62
src/Xanthous/Entities/RawTypes.hs
Normal 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) #-}
|
28
src/Xanthous/Entities/Raws.hs
Normal file
28
src/Xanthous/Entities/Raws.hs
Normal 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
|
12
src/Xanthous/Entities/Raws/gormlak.yaml
Normal file
12
src/Xanthous/Entities/Raws/gormlak.yaml
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
]
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
-- |
|
||||
|
||||
module Xanthous.DataSpec where
|
||||
module Xanthous.DataSpec (main, test) where
|
||||
|
||||
import Test.Prelude hiding (Right, Left, Down)
|
||||
import Xanthous.Data
|
||||
|
|
16
test/Xanthous/Entities/RawsSpec.hs
Normal file
16
test/Xanthous/Entities/RawsSpec.hs
Normal 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 ()
|
||||
]
|
||||
]
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue