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.

5 files changed, 173 insertions, 6 deletions

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