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.

10 files changed, 204 insertions, 10 deletions

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